From: Stephane Glondu Date: Tue, 27 Mar 2012 09:11:29 +0000 (+0200) Subject: Imported Upstream version 4.00.0~~dev15+12379 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~14 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=94f43cd11cead554e8062922176d15abbee967b4;p=ocaml.git Imported Upstream version 4.00.0~~dev15+12379 --- diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index e90edd4b..00000000 --- a/.cvsignore +++ /dev/null @@ -1,19 +0,0 @@ -.depend -configure -ocamlc -ocamlc.opt -expunge -ocaml -ocamlopt -ocamlopt.opt -ocamlcomp.sh -ocamlcompopt.sh -package-macosx -.DS_Store -*.annot -_boot_log1 -_boot_log2 -_build -_log -myocamlbuild_config.ml -ocamlnat diff --git a/.depend b/.depend index 2c1a7958..b64c1e79 100644 --- a/.depend +++ b/.depend @@ -1,774 +1,806 @@ -utils/ccomp.cmi: -utils/clflags.cmi: -utils/config.cmi: -utils/consistbl.cmi: -utils/misc.cmi: -utils/tbl.cmi: -utils/terminfo.cmi: -utils/warnings.cmi: -utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \ +utils/ccomp.cmi : +utils/clflags.cmi : +utils/config.cmi : +utils/consistbl.cmi : +utils/misc.cmi : +utils/tbl.cmi : +utils/terminfo.cmi : +utils/warnings.cmi : +utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi -utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \ +utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \ utils/ccomp.cmi -utils/clflags.cmo: utils/config.cmi utils/clflags.cmi -utils/clflags.cmx: utils/config.cmx utils/clflags.cmi -utils/config.cmo: utils/config.cmi -utils/config.cmx: utils/config.cmi -utils/consistbl.cmo: utils/consistbl.cmi -utils/consistbl.cmx: utils/consistbl.cmi -utils/misc.cmo: utils/misc.cmi -utils/misc.cmx: utils/misc.cmi -utils/tbl.cmo: utils/tbl.cmi -utils/tbl.cmx: utils/tbl.cmi -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/asttypes.cmi: -parsing/lexer.cmi: parsing/parser.cmi parsing/location.cmi -parsing/linenum.cmi: -parsing/location.cmi: utils/warnings.cmi -parsing/longident.cmi: -parsing/parse.cmi: parsing/parsetree.cmi -parsing/parser.cmi: parsing/parsetree.cmi -parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \ +utils/clflags.cmo : utils/config.cmi utils/clflags.cmi +utils/clflags.cmx : utils/config.cmx utils/clflags.cmi +utils/config.cmo : utils/config.cmi +utils/config.cmx : utils/config.cmi +utils/consistbl.cmo : utils/consistbl.cmi +utils/consistbl.cmx : utils/consistbl.cmi +utils/misc.cmo : utils/misc.cmi +utils/misc.cmx : utils/misc.cmi +utils/tbl.cmo : utils/tbl.cmi +utils/tbl.cmx : utils/tbl.cmi +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/asttypes.cmi : +parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi +parsing/location.cmi : utils/warnings.cmi +parsing/longident.cmi : +parsing/parse.cmi : parsing/parsetree.cmi +parsing/parser.cmi : parsing/parsetree.cmi +parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ parsing/asttypes.cmi -parsing/printast.cmi: parsing/parsetree.cmi -parsing/syntaxerr.cmi: parsing/location.cmi -parsing/lexer.cmo: utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ +parsing/printast.cmi : parsing/parsetree.cmi +parsing/syntaxerr.cmi : parsing/location.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 \ +parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ parsing/location.cmx parsing/lexer.cmi -parsing/linenum.cmo: utils/misc.cmi parsing/linenum.cmi -parsing/linenum.cmx: utils/misc.cmx parsing/linenum.cmi -parsing/location.cmo: utils/warnings.cmi utils/terminfo.cmi \ - parsing/linenum.cmi parsing/location.cmi -parsing/location.cmx: utils/warnings.cmx utils/terminfo.cmx \ - parsing/linenum.cmx parsing/location.cmi -parsing/longident.cmo: utils/misc.cmi parsing/longident.cmi -parsing/longident.cmx: utils/misc.cmx parsing/longident.cmi -parsing/parse.cmo: parsing/syntaxerr.cmi parsing/parser.cmi \ +parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \ + parsing/location.cmi +parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ + parsing/location.cmi +parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi +parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi +parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi -parsing/parse.cmx: parsing/syntaxerr.cmx parsing/parser.cmx \ +parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi -parsing/parser.cmo: parsing/syntaxerr.cmi parsing/parsetree.cmi \ +parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ parsing/asttypes.cmi parsing/parser.cmi -parsing/parser.cmx: parsing/syntaxerr.cmx 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/printast.cmo: parsing/parsetree.cmi parsing/longident.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 \ +parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi -parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi -parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi -typing/annot.cmi: parsing/location.cmi -typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi -typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \ - typing/env.cmi parsing/asttypes.cmi -typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi -typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ - typing/ident.cmi utils/consistbl.cmi typing/annot.cmi -typing/ident.cmi: -typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \ - typing/ctype.cmi -typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \ +parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi +parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi +typing/annot.cmi : parsing/location.cmi +typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi +typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +typing/datarepr.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi +typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + utils/consistbl.cmi typing/annot.cmi +typing/ident.cmi : +typing/includeclass.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/env.cmi typing/ctype.cmi +typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ typing/ident.cmi typing/env.cmi -typing/includemod.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ - typing/includecore.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi -typing/mtype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \ +typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/path.cmi typing/includecore.cmi typing/ident.cmi typing/env.cmi \ + typing/ctype.cmi +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 \ - parsing/location.cmi typing/env.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/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi -typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi -typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \ +typing/oprint.cmi : typing/outcometree.cmi +typing/outcometree.cmi : parsing/asttypes.cmi +typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi parsing/location.cmi typing/env.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/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ + typing/annot.cmi +typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi +typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi -typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ +typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi -typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ +typing/typedecl.cmi : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ typing/ident.cmi typing/env.cmi -typing/typedtree.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ +typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -typing/typemod.cmi: typing/types.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 -typing/types.cmi: typing/primitive.cmi typing/path.cmi typing/ident.cmi \ +typing/types.cmi : typing/primitive.cmi typing/path.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ parsing/asttypes.cmi -typing/typetexp.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ +typing/typetexp.cmi : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi typing/env.cmi -typing/unused_var.cmi: parsing/parsetree.cmi -typing/btype.cmo: typing/types.cmi typing/path.cmi utils/misc.cmi \ +typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ typing/btype.cmi -typing/btype.cmx: typing/types.cmx typing/path.cmx utils/misc.cmx \ +typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ typing/btype.cmi -typing/ctype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \ - utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/ctype.cmi -typing/ctype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \ - utils/misc.cmx parsing/longident.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 \ - parsing/asttypes.cmi typing/datarepr.cmi -typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \ - parsing/asttypes.cmi typing/datarepr.cmi -typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \ - typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \ - typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.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 \ + parsing/asttypes.cmi typing/ctype.cmi +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/btype.cmi parsing/asttypes.cmi typing/datarepr.cmi +typing/datarepr.cmx : typing/types.cmx typing/predef.cmx utils/misc.cmx \ + typing/btype.cmx parsing/asttypes.cmi typing/datarepr.cmi +typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ + typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ typing/env.cmi -typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \ - typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ +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 \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ typing/env.cmi -typing/ident.cmo: typing/ident.cmi -typing/ident.cmx: typing/ident.cmi -typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \ +typing/ident.cmo : typing/ident.cmi +typing/ident.cmx : typing/ident.cmi +typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ typing/ctype.cmi typing/includeclass.cmi -typing/includeclass.cmx: typing/types.cmx typing/printtyp.cmx \ +typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \ typing/ctype.cmx typing/includeclass.cmi -typing/includecore.cmo: typing/types.cmi typing/typedtree.cmi \ - typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ctype.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi -typing/includecore.cmx: typing/types.cmx typing/typedtree.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ctype.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi -typing/includemod.cmo: typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ +typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \ + typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/includecore.cmi +typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/includecore.cmi +typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \ - utils/misc.cmi typing/includecore.cmi typing/includeclass.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/includemod.cmi -typing/includemod.cmx: typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ + utils/misc.cmi parsing/location.cmi typing/includecore.cmi \ + typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/clflags.cmi typing/includemod.cmi +typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \ - utils/misc.cmx typing/includecore.cmx typing/includeclass.cmx \ - typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/includemod.cmi -typing/mtype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \ + utils/misc.cmx parsing/location.cmx typing/includecore.cmx \ + typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/clflags.cmx typing/includemod.cmi +typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi typing/mtype.cmi -typing/mtype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \ +typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi typing/mtype.cmi -typing/oprint.cmo: typing/outcometree.cmi parsing/asttypes.cmi \ +typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi -typing/oprint.cmx: typing/outcometree.cmi parsing/asttypes.cmi \ +typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi -typing/parmatch.cmo: utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \ - typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ +typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ typing/parmatch.cmi -typing/parmatch.cmx: utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \ - typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ +typing/parmatch.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typedtree.cmx typing/subst.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/parmatch.cmi -typing/path.cmo: typing/ident.cmi typing/path.cmi -typing/path.cmx: typing/ident.cmx typing/path.cmi -typing/predef.cmo: typing/types.cmi typing/path.cmi typing/ident.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi -typing/predef.cmx: typing/types.cmx typing/path.cmx typing/ident.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi -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/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/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \ +typing/path.cmo : typing/ident.cmi typing/path.cmi +typing/path.cmx : typing/ident.cmx typing/path.cmi +typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ + typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi +typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ + typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi +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/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/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \ parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi -typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \ +typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \ parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi -typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \ - utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi -typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \ - utils/misc.cmx typing/ident.cmx typing/btype.cmx typing/subst.cmi -typing/typeclass.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ - typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ +typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/btype.cmi \ + typing/subst.cmi +typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/btype.cmx \ + typing/subst.cmi +typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ + typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi typing/typeclass.cmi -typing/typeclass.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ - typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \ +typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ + typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi typing/typeclass.cmi -typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ - typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \ +typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \ typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ typing/typecore.cmi -typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ - typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ +typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \ typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ typing/typecore.cmi -typing/typedecl.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ - typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/primitive.cmi typing/predef.cmi typing/path.cmi \ - parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/includecore.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/typedecl.cmi -typing/typedecl.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ - typing/typedtree.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/primitive.cmx typing/predef.cmx typing/path.cmx \ - parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/includecore.cmx typing/ident.cmx \ - typing/env.cmx typing/ctype.cmx utils/config.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/typedecl.cmi -typing/typedtree.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \ +typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/subst.cmi \ + typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/typedecl.cmi +typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/subst.cmx \ + typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/typedecl.cmi +typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi typing/typedtree.cmi -typing/typedtree.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ +typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ parsing/asttypes.cmi typing/typedtree.cmi -typing/typemod.cmo: typing/typetexp.cmi typing/types.cmi typing/typedtree.cmi \ - typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \ - typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/path.cmi \ - parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \ - parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ - typing/typemod.cmi -typing/typemod.cmx: typing/typetexp.cmx typing/types.cmx typing/typedtree.cmx \ - typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \ - typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/path.cmx \ - parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \ - parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \ - typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ - 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/ident.cmi parsing/asttypes.cmi typing/types.cmi -typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \ - typing/ident.cmx parsing/asttypes.cmi typing/types.cmi -typing/typetexp.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.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 \ + typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \ + typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi +typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ + typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ + typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi \ + typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/includemod.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx utils/config.cmx 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 \ + 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 \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + parsing/asttypes.cmi typing/types.cmi +typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/env.cmi \ typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ typing/typetexp.cmi -typing/typetexp.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ +typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/env.cmx \ typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/typetexp.cmi -typing/unused_var.cmo: utils/warnings.cmi parsing/parsetree.cmi \ - parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ - typing/unused_var.cmi -typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \ - parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ - typing/unused_var.cmi -bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi -bytecomp/bytelibrarian.cmi: -bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi -bytecomp/bytepackager.cmi: typing/ident.cmi -bytecomp/bytesections.cmi: -bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi -bytecomp/dll.cmi: -bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi -bytecomp/instruct.cmi: typing/types.cmi typing/subst.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ +bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi +bytecomp/bytelibrarian.cmi : +bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi +bytecomp/bytepackager.cmi : typing/ident.cmi +bytecomp/bytesections.cmi : +bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi +bytecomp/dll.cmi : +bytecomp/emitcode.cmi : bytecomp/instruct.cmi bytecomp/cmo_format.cmi +bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \ +bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/meta.cmi: -bytecomp/printinstr.cmi: bytecomp/instruct.cmi -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/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \ +bytecomp/meta.cmi : +bytecomp/printinstr.cmi : bytecomp/instruct.cmi +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/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 \ +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/translmod.cmi: typing/typedtree.cmi typing/primitive.cmi \ +bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi -bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \ +bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/typeopt.cmi : typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi -bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ +bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \ parsing/asttypes.cmi bytecomp/bytegen.cmi -bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ +bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \ parsing/asttypes.cmi bytecomp/bytegen.cmi -bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ - bytecomp/bytelibrarian.cmi -bytecomp/bytelibrarian.cmx: utils/misc.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ - bytecomp/bytelibrarian.cmi -bytecomp/bytelink.cmo: bytecomp/symtable.cmi bytecomp/opcodes.cmo \ - utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \ +bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi +bytecomp/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/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \ - utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \ +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/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \ - typing/subst.cmi typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi \ - typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ - bytecomp/bytegen.cmi bytecomp/bytepackager.cmi -bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ - typing/subst.cmx typing/path.cmx utils/misc.cmx bytecomp/instruct.cmx \ - typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ - bytecomp/bytegen.cmx bytecomp/bytepackager.cmi -bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi -bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi -bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi -bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi -bytecomp/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \ +bytecomp/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 \ + bytecomp/emitcode.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi bytecomp/bytelink.cmi bytecomp/bytegen.cmi \ + bytecomp/bytepackager.cmi +bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ + typing/subst.cmx typing/path.cmx utils/misc.cmx parsing/location.cmx \ + bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytegen.cmx \ + bytecomp/bytepackager.cmi +bytecomp/bytesections.cmo : utils/misc.cmi utils/config.cmi \ + bytecomp/bytesections.cmi +bytecomp/bytesections.cmx : utils/misc.cmx utils/config.cmx \ + bytecomp/bytesections.cmi +bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi +bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi +bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ +bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/instruct.cmo: typing/types.cmi typing/subst.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi -bytecomp/instruct.cmx: typing/types.cmx typing/subst.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi -bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \ +bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + bytecomp/instruct.cmi +bytecomp/instruct.cmx : typing/types.cmx typing/subst.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/instruct.cmi +bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi bytecomp/lambda.cmi -bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ +bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ parsing/asttypes.cmi bytecomp/lambda.cmi -bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \ +bytecomp/matching.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi \ typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ bytecomp/matching.cmi -bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \ +bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ typing/primitive.cmx typing/predef.cmx typing/path.cmx \ typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/matching.cmi -bytecomp/meta.cmo: bytecomp/meta.cmi -bytecomp/meta.cmx: bytecomp/meta.cmi -bytecomp/opcodes.cmo: -bytecomp/opcodes.cmx: -bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \ +bytecomp/meta.cmo : bytecomp/meta.cmi +bytecomp/meta.cmx : bytecomp/meta.cmi +bytecomp/opcodes.cmo : +bytecomp/opcodes.cmx : +bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ bytecomp/printinstr.cmi -bytecomp/printinstr.cmx: bytecomp/printlambda.cmx parsing/location.cmx \ +bytecomp/printinstr.cmx : bytecomp/printlambda.cmx parsing/location.cmx \ bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ bytecomp/printinstr.cmi -bytecomp/printlambda.cmo: typing/types.cmi typing/primitive.cmi \ +bytecomp/printlambda.cmo : typing/types.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ parsing/asttypes.cmi bytecomp/printlambda.cmi -bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.cmx \ +bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ parsing/asttypes.cmi bytecomp/printlambda.cmi -bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi -bytecomp/simplif.cmo: typing/stypes.cmi bytecomp/lambda.cmi typing/ident.cmi \ - utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ +bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi +bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi +bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi bytecomp/lambda.cmi \ + typing/ident.cmi utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ bytecomp/simplif.cmi -bytecomp/simplif.cmx: typing/stypes.cmx bytecomp/lambda.cmx typing/ident.cmx \ - utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ +bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \ + typing/ident.cmx utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ bytecomp/simplif.cmi -bytecomp/switch.cmo: bytecomp/switch.cmi -bytecomp/switch.cmx: bytecomp/switch.cmi -bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \ +bytecomp/switch.cmo : bytecomp/switch.cmi +bytecomp/switch.cmx : bytecomp/switch.cmi +bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ typing/ident.cmi bytecomp/dll.cmi bytecomp/cmo_format.cmi \ utils/clflags.cmi bytecomp/bytesections.cmi parsing/asttypes.cmi \ bytecomp/symtable.cmi -bytecomp/symtable.cmx: utils/tbl.cmx bytecomp/runtimedef.cmx \ +bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ typing/ident.cmx bytecomp/dll.cmx bytecomp/cmo_format.cmi \ utils/clflags.cmx bytecomp/bytesections.cmx parsing/asttypes.cmi \ bytecomp/symtable.cmi -bytecomp/translclass.cmo: typing/types.cmi bytecomp/typeopt.cmi \ +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 \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi -bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.cmx \ +bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ typing/path.cmx utils/misc.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 \ +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/location.cmi bytecomp/lambda.cmi \ typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi -bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \ +bytecomp/translcore.cmx : typing/types.cmx 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/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/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 \ typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi -bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \ +bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \ bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi -bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \ +bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \ parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ bytecomp/translobj.cmi -bytecomp/translobj.cmx: typing/primitive.cmx utils/misc.cmx \ +bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \ parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/translobj.cmi -bytecomp/typeopt.cmo: typing/types.cmi typing/typedtree.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 -bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ +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 -asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi -asmcomp/asmlibrarian.cmi: -asmcomp/asmlink.cmi: asmcomp/cmx_format.cmi -asmcomp/asmpackager.cmi: -asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ +asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/asmlibrarian.cmi : +asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi +asmcomp/asmpackager.cmi : +asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi -asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi -asmcomp/cmmgen.cmi: asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ - asmcomp/clambda.cmi -asmcomp/cmx_format.cmi: asmcomp/clambda.cmi -asmcomp/codegen.cmi: asmcomp/cmm.cmi -asmcomp/coloring.cmi: -asmcomp/comballoc.cmi: asmcomp/mach.cmi -asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/cmx_format.cmi \ +asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi +asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi +asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ asmcomp/clambda.cmi -asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi -asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.cmi -asmcomp/emitaux.cmi: asmcomp/debuginfo.cmi -asmcomp/interf.cmi: asmcomp/mach.cmi -asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi -asmcomp/liveness.cmi: asmcomp/mach.cmi -asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ +asmcomp/cmx_format.cmi : asmcomp/clambda.cmi +asmcomp/codegen.cmi : asmcomp/cmm.cmi +asmcomp/coloring.cmi : +asmcomp/comballoc.cmi : asmcomp/mach.cmi +asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/cmx_format.cmi asmcomp/clambda.cmi +asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi +asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi +asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi +asmcomp/interf.cmi : asmcomp/mach.cmi +asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/debuginfo.cmi +asmcomp/liveness.cmi : asmcomp/mach.cmi +asmcomp/mach.cmi : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo -asmcomp/printcmm.cmi: asmcomp/cmm.cmi -asmcomp/printlinear.cmi: asmcomp/linearize.cmi -asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/reg.cmi: asmcomp/cmm.cmi -asmcomp/reload.cmi: asmcomp/mach.cmi -asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi -asmcomp/scheduling.cmi: asmcomp/linearize.cmi -asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ +asmcomp/printclambda.cmi : asmcomp/clambda.cmi +asmcomp/printcmm.cmi : asmcomp/cmm.cmi +asmcomp/printlinear.cmi : asmcomp/linearize.cmi +asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/reg.cmi : asmcomp/cmm.cmi +asmcomp/reload.cmi : asmcomp/mach.cmi +asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi +asmcomp/scheduling.cmi : asmcomp/linearize.cmi +asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo -asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi -asmcomp/spill.cmi: asmcomp/mach.cmi -asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: -asmcomp/arch.cmx: -asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ +asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi +asmcomp/spill.cmi : asmcomp/mach.cmi +asmcomp/split.cmi : asmcomp/mach.cmi +asmcomp/arch.cmo : +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 asmcomp/liveness.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/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 asmcomp/liveness.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/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 \ asmcomp/asmlibrarian.cmi -asmcomp/asmlibrarian.cmx: utils/misc.cmx utils/config.cmx \ +asmcomp/asmlibrarian.cmx : utils/misc.cmx utils/config.cmx \ asmcomp/compilenv.cmx asmcomp/cmx_format.cmi utils/clflags.cmx \ asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi -asmcomp/asmlink.cmo: bytecomp/runtimedef.cmi asmcomp/proc.cmi utils/misc.cmi \ - parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ +asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi asmcomp/proc.cmi \ + utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \ utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi -asmcomp/asmlink.cmx: bytecomp/runtimedef.cmx asmcomp/proc.cmx utils/misc.cmx \ - parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ +asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx asmcomp/proc.cmx \ + utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi -asmcomp/asmpackager.cmo: typing/typemod.cmi bytecomp/translmod.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 \ asmcomp/asmpackager.cmi -asmcomp/asmpackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ +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 \ asmcomp/asmpackager.cmi -asmcomp/clambda.cmo: bytecomp/lambda.cmi typing/ident.cmi \ +asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi -asmcomp/clambda.cmx: bytecomp/lambda.cmx typing/ident.cmx \ +asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi -asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ +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 -asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ +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 -asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ +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 \ +asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ asmcomp/cmm.cmi -asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ +asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \ asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ asmcomp/cmmgen.cmi -asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \ +asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \ typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \ asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ asmcomp/cmmgen.cmi -asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ +asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \ asmcomp/interf.cmi asmcomp/emit.cmi asmcomp/coloring.cmi asmcomp/cmm.cmi \ asmcomp/codegen.cmi -asmcomp/codegen.cmx: asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \ +asmcomp/codegen.cmx : asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \ asmcomp/reg.cmx asmcomp/printmach.cmx asmcomp/printlinear.cmx \ asmcomp/printcmm.cmx asmcomp/liveness.cmx asmcomp/linearize.cmx \ asmcomp/interf.cmx asmcomp/emit.cmx asmcomp/coloring.cmx asmcomp/cmm.cmx \ asmcomp/codegen.cmi -asmcomp/coloring.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi -asmcomp/coloring.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi -asmcomp/comballoc.cmo: asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ +asmcomp/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi +asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi +asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ asmcomp/arch.cmo asmcomp/comballoc.cmi -asmcomp/comballoc.cmx: asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ +asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ asmcomp/arch.cmx asmcomp/comballoc.cmi -asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi asmcomp/cmx_format.cmi asmcomp/clambda.cmi \ - asmcomp/compilenv.cmi -asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx asmcomp/cmx_format.cmi asmcomp/clambda.cmx \ - asmcomp/compilenv.cmi -asmcomp/debuginfo.cmo: parsing/location.cmi bytecomp/lambda.cmi \ +asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ + asmcomp/cmx_format.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi +asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ + asmcomp/cmx_format.cmi asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi -asmcomp/debuginfo.cmx: parsing/location.cmx bytecomp/lambda.cmx \ +asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ asmcomp/debuginfo.cmi -asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ +asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \ asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi -asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ +asmcomp/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 asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/emitaux.cmi -asmcomp/emitaux.cmx: asmcomp/reg.cmx asmcomp/linearize.cmx \ - asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/emitaux.cmi -asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.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/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/interf.cmi -asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.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 -asmcomp/linearize.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ +asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/linearize.cmi -asmcomp/liveness.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi -asmcomp/liveness.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmi -asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ +asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/liveness.cmi +asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/liveness.cmi +asmcomp/mach.cmo : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/mach.cmi -asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ +asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/mach.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 asmcomp/cmm.cmx \ - asmcomp/printcmm.cmi -asmcomp/printlinear.cmo: asmcomp/printmach.cmi 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 +asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ + typing/ident.cmx asmcomp/debuginfo.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 \ + asmcomp/cmm.cmx asmcomp/printcmm.cmi +asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/debuginfo.cmi asmcomp/printlinear.cmi -asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \ +asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi -asmcomp/printmach.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi \ - asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/printmach.cmi -asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \ - asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/printmach.cmi -asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ - utils/config.cmi asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo \ - asmcomp/proc.cmi -asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ - utils/config.cmx asmcomp/cmm.cmx utils/ccomp.cmx asmcomp/arch.cmx \ - asmcomp/proc.cmi -asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi -asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ +asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printcmm.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi +asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printcmm.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi +asmcomp/proc.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ + utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ + asmcomp/arch.cmo asmcomp/proc.cmi +asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ + asmcomp/arch.cmx asmcomp/proc.cmi +asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi +asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi +asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ +asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi -asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi -asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +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 utils/misc.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 utils/misc.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 -asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi -asmcomp/selectgen.cmo: utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ +asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/selectgen.cmi -asmcomp/selectgen.cmx: utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ +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/debuginfo.cmi asmcomp/cmm.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/debuginfo.cmx asmcomp/cmm.cmx \ +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/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.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 \ +asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/spill.cmi -asmcomp/split.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmi -asmcomp/split.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi -driver/compile.cmi: typing/env.cmi -driver/errors.cmi: -driver/main.cmi: -driver/main_args.cmi: -driver/optcompile.cmi: typing/env.cmi -driver/opterrors.cmi: -driver/optmain.cmi: -driver/pparse.cmi: -driver/compile.cmo: utils/warnings.cmi typing/unused_var.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 utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi -driver/compile.cmx: utils/warnings.cmx typing/unused_var.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 utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.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 bytecomp/translclass.cmi \ - parsing/syntaxerr.cmi bytecomp/symtable.cmi driver/pparse.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/env.cmi typing/ctype.cmi bytecomp/bytepackager.cmi \ - bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/errors.cmi -driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \ - typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \ - bytecomp/translmod.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ - parsing/syntaxerr.cmx bytecomp/symtable.cmx driver/pparse.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \ - bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi -driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.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/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.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/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/unused_var.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 \ +driver/compile.cmi : typing/env.cmi +driver/errors.cmi : +driver/main.cmi : +driver/main_args.cmi : +driver/optcompile.cmi : typing/env.cmi +driver/opterrors.cmi : +driver/optmain.cmi : +driver/pparse.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 utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ - utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi -driver/optcompile.cmx: utils/warnings.cmx typing/unused_var.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 \ + typing/env.cmi bytecomp/emitcode.cmi utils/config.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 utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ - utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi -driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \ + typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \ + utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.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 \ + bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \ + driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \ + typing/includemod.cmi typing/env.cmi typing/ctype.cmi \ + bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ + bytecomp/bytelibrarian.cmi driver/errors.cmi +driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ + typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ + bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \ + driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \ + typing/includemod.cmx typing/env.cmx typing/ctype.cmx \ + bytecomp/bytepackager.cmx bytecomp/bytelink.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/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/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 +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 +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 \ bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \ @@ -776,7 +808,7 @@ driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \ typing/env.cmi typing/ctype.cmi asmcomp/compilenv.cmi \ asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \ asmcomp/asmgen.cmi driver/opterrors.cmi -driver/opterrors.cmx: utils/warnings.cmx typing/typetexp.cmx \ +driver/opterrors.cmx : utils/warnings.cmx typing/typetexp.cmx \ typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ bytecomp/translclass.cmx parsing/syntaxerr.cmx driver/pparse.cmx \ @@ -784,135 +816,139 @@ driver/opterrors.cmx: utils/warnings.cmx typing/typetexp.cmx \ typing/env.cmx typing/ctype.cmx asmcomp/compilenv.cmx \ asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \ asmcomp/asmgen.cmx driver/opterrors.cmi -driver/optmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \ +driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \ - driver/main_args.cmi utils/config.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/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/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \ - driver/main_args.cmx utils/config.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 \ + 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/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 \ +driver/pparse.cmx : utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ utils/ccomp.cmx driver/pparse.cmi -toplevel/genprintval.cmi: typing/types.cmi typing/path.cmi \ +toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi -toplevel/opttopdirs.cmi: parsing/longident.cmi -toplevel/opttoploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ - parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ - parsing/location.cmi typing/env.cmi -toplevel/opttopmain.cmi: -toplevel/topdirs.cmi: parsing/longident.cmi -toplevel/toploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ +toplevel/opttopdirs.cmi : parsing/longident.cmi +toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \ + typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi +toplevel/opttopmain.cmi : +toplevel/topdirs.cmi : parsing/longident.cmi +toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \ parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ parsing/location.cmi typing/env.cmi -toplevel/topmain.cmi: -toplevel/trace.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ +toplevel/topmain.cmi : +toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/env.cmi -toplevel/expunge.cmo: bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ +toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ utils/misc.cmi typing/ident.cmi bytecomp/bytesections.cmi -toplevel/expunge.cmx: bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ +toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ utils/misc.cmx typing/ident.cmx bytecomp/bytesections.cmx -toplevel/genprintval.cmo: typing/types.cmi typing/printtyp.cmi \ +toplevel/genprintval.cmo : typing/types.cmi typing/printtyp.cmi \ typing/predef.cmi typing/path.cmi typing/outcometree.cmi utils/misc.cmi \ parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ typing/ctype.cmi typing/btype.cmi toplevel/genprintval.cmi -toplevel/genprintval.cmx: typing/types.cmx typing/printtyp.cmx \ +toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \ typing/predef.cmx typing/path.cmx typing/outcometree.cmi utils/misc.cmx \ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi -toplevel/opttopdirs.cmo: utils/warnings.cmi typing/types.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 \ toplevel/opttopdirs.cmi -toplevel/opttopdirs.cmx: utils/warnings.cmx typing/types.cmx \ +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 \ toplevel/opttopdirs.cmi -toplevel/opttoploop.cmo: utils/warnings.cmi typing/unused_var.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 \ +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 \ 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 -toplevel/opttoploop.cmx: utils/warnings.cmx typing/unused_var.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 \ +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 \ 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 -toplevel/opttopmain.cmo: utils/warnings.cmi asmcomp/printmach.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 utils/config.cmi utils/clflags.cmi \ - toplevel/opttopmain.cmi -toplevel/opttopmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \ + utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.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 utils/config.cmx utils/clflags.cmx \ - toplevel/opttopmain.cmi -toplevel/opttopstart.cmo: toplevel/opttopmain.cmi -toplevel/opttopstart.cmx: toplevel/opttopmain.cmx -toplevel/topdirs.cmo: utils/warnings.cmi typing/types.cmi toplevel/trace.cmi \ - toplevel/toploop.cmi bytecomp/symtable.cmi typing/printtyp.cmi \ - typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ - parsing/longident.cmi typing/ident.cmi typing/env.cmi bytecomp/dll.cmi \ - typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ + utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \ + utils/clflags.cmx toplevel/opttopmain.cmi +toplevel/opttopstart.cmo : toplevel/opttopmain.cmi +toplevel/opttopstart.cmx : toplevel/opttopmain.cmx +toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ + toplevel/trace.cmi toplevel/toploop.cmi bytecomp/symtable.cmi \ + typing/printtyp.cmi typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ + bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi toplevel/topdirs.cmi -toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \ - toplevel/toploop.cmx bytecomp/symtable.cmx typing/printtyp.cmx \ - typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ - parsing/longident.cmx typing/ident.cmx typing/env.cmx bytecomp/dll.cmx \ - typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ +toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \ + toplevel/trace.cmx toplevel/toploop.cmx bytecomp/symtable.cmx \ + typing/printtyp.cmx typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi -toplevel/toploop.cmo: utils/warnings.cmi typing/unused_var.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 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/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \ - typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ +toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ + bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \ + parsing/printast.cmi typing/predef.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/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 \ bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi -toplevel/toploop.cmx: utils/warnings.cmx typing/unused_var.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 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/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \ - typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ +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 \ + 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/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 \ bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi -toplevel/topmain.cmo: utils/warnings.cmi toplevel/toploop.cmi \ +toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ - driver/errors.cmi utils/config.cmi utils/clflags.cmi toplevel/topmain.cmi -toplevel/topmain.cmx: utils/warnings.cmx toplevel/toploop.cmx \ + parsing/location.cmi driver/errors.cmi utils/config.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 \ - driver/errors.cmx utils/config.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 typing/printtyp.cmi \ - typing/predef.cmi typing/path.cmi utils/misc.cmi bytecomp/meta.cmi \ - parsing/longident.cmi typing/ctype.cmi toplevel/trace.cmi -toplevel/trace.cmx: typing/types.cmx toplevel/toploop.cmx typing/printtyp.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx bytecomp/meta.cmx \ - parsing/longident.cmx typing/ctype.cmx toplevel/trace.cmi + parsing/location.cmx driver/errors.cmx utils/config.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 \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi typing/ctype.cmi \ + toplevel/trace.cmi +toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \ + toplevel/trace.cmi diff --git a/.ignore b/.ignore new file mode 100644 index 00000000..c801c474 --- /dev/null +++ b/.ignore @@ -0,0 +1,17 @@ +configure +ocamlc +ocamlc.opt +expunge +ocaml +ocamlopt +ocamlopt.opt +ocamlcomp.sh +ocamlcompopt.sh +package-macosx +_boot_log1 +_boot_log2 +_build +_log +myocamlbuild_config.ml +ocamlbuild-mixed-boot +ocamlnat diff --git a/Changes b/Changes index 2e7b5780..90030e80 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,181 @@ -Objective Caml 3.12.1: ----------------------- +OCaml 4.00.0: +------------- + +(Changes that can break existing programs are marked with a "*") + +- The official name of the language is now OCaml. + +Language features: +- Added Generalized Abstract Data Types (GADTs) to the language. See + testsuite/tests/typing-gadts for the syntax and some examples of + use. Please use -principal for testing. +- It is now possible to omit type annotations when packing and unpacking + first-class modules. The type-checker attempts to infer it from the context. + Using the -principal option guarantees forward compatibility. +- New (module M) and (module M : S) syntax in patterns, for immediate + unpacking of a first-class module. + +Compilers: +- Revised simplification of let-alias (PR#5205, PR#5288) +- Better reporting of compiler version mismatch in .cmi files +* Warning 28 is now enabled by default. +- New option -absname to use absolute paths in error messages +- Optimize away compile-time beta-redexes, e.g. (fun x y -> e) a b. + +Native-code compiler: +- Optimized handling of partially-applied functions (PR#5287) +- Small improvements in code generated for array bounds checks (PR#5345, + PR#5360). +* New ARM backend (PR#5433): + . Supports both Linux/EABI (armel) and Linux/EABI+VFPv3 (armhf). + . Added support for the Thumb-2 instruction set with average code size + savings of 28%. + . Added support for position-independent code, natdynlink, profiling and + exception backtraces. +- In -g mode, generation of CFI information and a few filename/line + number debugging annotations, enabling in particular precise stack + backtraces with the gdb debugger. Currently supported for x86 32-bits + and 64-bits only. (PR#5487) +- New tool: ocamloptp, the equivalent of ocamlcp for the native-code compiler. + +Standard library: +- Added float functions "hypot" and "copysign" (PR#3806, PR#4752, PR#5246) +* Arg: options with empty doc strings are no longer included in the usage string + (PR#5437) +- Array: faster implementations of "blit", "copy", "sub", "append" and "concat" + (PR#2395, PR#2787, PR#4591) +* Hashtbl: + . Statistically-better generic hash function based on Murmur 3 (PR#5225) + . Fixed behavior of generic hash function w.r.t. -0.0 and NaN (PR#5222) + . Added optional "seed" parameter to Hashtbl.create for diversification + . Added new functorial interface "MakeSeeded" to support diversification + with user-provided hash functions. +- Marshal: marshalling of function values (flag Marshal.Closures) now + also works for functions that come from dynamically-loaded modules (PR#5215) +- Random: + . More random initialization (Random.self_init()), using /dev/urandom + when available (e.g. Linux, FreeBSD, MacOS X, Solaris) + . Faster implementation of Random.float +- Scanf: new function "unescaped" (PR#3888) +- Set and Map: more efficient implementation of "filter" and "partition" +- String: new function "map" (PR#3888) + +Other libraries: +- Bigarray: added "release" functions that free memory and file mappings + just like GC finalization does eventually, but does it immediately. + +Bug Fixes: +- PR#1643: functions of the Lazy module whose named started with 'lazy_' have + been deprecated, and new ones without the prefix added +- PR#3571: in Bigarrays, call msync() before unmapping to commit changes +- PR#4549: Filename.dirname is not handling multiple / on Unix +- PR#4688: (Windows) special floating-point values aren't converted to strings + correctly +- PR#4697: Unix.putenv leaks memory on failure +- PR#4705: camlp4 does not allow to define types with `True or `False +- PR#4746: wrong detection of stack overflows in native code under Linux +- PR#4869: rare collisions between assembly labels for code and data +- PR#4880: "assert" constructs now show up in the exception stack backtrace +- PR#4892: Array.set could raise "out of bounds" before evaluating 3rd arg +- PR#4937: camlp4 incorrectly handles optional arguments if 'option' is + redefined +- PR#5024: camlp4r now handles underscores in irrefutable patern matching of + records +- PR#5064, PR#5485: try to ensure that 4K words of stack are available + before calling into C functions, raising a Stack_overflow exception + otherwise. This reduces (but does not eliminate) the risk of + segmentation faults due to stack overflow in C code +- PR#5211: updated Genlex documentation to state that camlp4 is mandatory for + 'parser' keyword and associated notation +- PR#5238, PR#5277: Sys_error when getting error location +- PR#5295: OS threads: problem with caml_c_thread_unregister() +- PR#5301: camlp4r and exception equal to another one with parameters +- PR#5309: Queue.add is not thread/signal safe +- PR#5310: Ratio.create_ratio/create_normalized_ratio have misleading names +- PR#5311: better message for warning 23 +- PR#5313: ocamlopt -g misses optimizations +- PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable +- 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#5327: (Windows) Unix.select blocks if same socket listed in first and + third arguments +- 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#5343: ocaml -rectypes is unsound wrt module subtyping +- PR#5344: some predifined exceptions need special printing +- PR#5356: ocamlbuild handling of 'predicates' for ocamlfind +- PR#5364: wrong compilation of "((val m : SIG1) : SIG2)" +- PR#5370: ocamldep omits filename in syntax error message +- PR#5380: strange sscanf input segfault +- PR#5394: Documentation for -dtypes is missing in manpage +- PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode +- PR#5436: update object ids on unmarshaling +- PR#5453: configure doesn't find X11 under Ubuntu/MultiarchSpec +- PR#5461: Double linking of bytecode modules +- PR#5463: Bigarray.*.map_file fail if empty array is requested +- PR#5469: private record type generated by functor loses abbreviation +- PR#5475: Wrapper script for interpreted LablTk wrongly handles command line + parameters +- PR#5476: bug in native code compilation of let rec on float arrays +- PR#5498: Unification with an empty object only checks the absence of + the first method +- PR#5503: error when ocamlbuild is passed an absolute path as build directory +- PR#5509: misclassification of statically-allocated empty array that + falls exactly at beginning of an otherwise unused data page. +- PR#5510: ocamldep has duplicate -ml{,i}-synonym options +- PR#5511: in Bigarray.reshape, unwarranted limitation on new array dimensions. +- PR#5513: Int64.div causes floating point exception (ocamlopt, x86) +- PR#5516: in Bigarray C stubs, use C99 flexible array types if possible +- PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file +- PR#5538: combining -i and -annot in ocamlc +- PR#5560: incompatible type for tuple pattern with -principal +- problem with printing of string literals in camlp4 (reported on caml-list) +- emacs mode: colorization of comments and strings now works correctly + +Feature wishes: +- PR#352: new option "-stdin" to make ocaml read stdin as a script +- PR#4444: new String.trim function, removing leading and trailing whistespace +- PR#4898: new Sys.big_endian boolean for machine endianness +- PR#5199: tests are run only for bytecode if either native support is missing, + or a non-empty value is set to "BYTECODE_ONLY" Makefile variable +- PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x', + and '%apply' with semantics 'apply f x = f x'. +- PR#5297: compiler now checks existence of builtin primitives +- PR#5329: (Windows) more efficient Unix.select if all fd's are sockets +- PR#5358: first class modules don't allow "with type" declarations for types + in sub-modules +- PR#5397: Filename.temp_dir_name should be mutable +- PR#5411: new directive for the toplevel: #load_rec +- PR#5420: Unix.openfile share mode (Windows) +- PR#5437: warning for useless open statements +- PR#5438: new warnings for unused declarations +- PR#5454: Digest.compare is missing and md5 doc update +- PR#5467: no extern "C" into ocaml C-stub headers +- PR#5478: ocamlopt assumes ar command exists +- PR#5479: Num.num_of_string may raise an exception, not reflected in the + documentation. +- ocamldebug: ability to inspect values that contain code pointers +- ocamldebug: new 'environment' directive to set environment variables + for debugee + +Shedding weight: +* Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS. +* The "DBM" library (interface with Unix DBM key-value stores) is no + longer part of this distribution. It now lives its own life at + https://forge.ocamlcore.org/projects/camldbm/ +* The "OCamlWin" toplevel user interface for MS Windows is no longer + part of this distribution. It now lives its own life at + https://forge.ocamlcore.org/projects/ocamltopwin/ + +Other changes: +- Copy VERSION file to library directory when installing. + + +OCaml 3.12.1: +------------- Bug fixes: - PR#4345, PR#4767: problems with camlp4 printing of float values @@ -95,6 +271,7 @@ Other changes: - Added new operation 'compare_ext' to custom blocks, called when comparing a custom block value with an unboxed integer. + Objective Caml 3.12.0: ---------------------- @@ -172,7 +349,7 @@ Compilers and toplevel: caused by the incomplete comparison of applicative paths F(X).t. Native-code compiler: -- AMD64: shorter and slightly more efficient code generated for +- AMD64: shorter and slightly more efficient code generated for float comparisons. Standard library: @@ -2720,5 +2897,3 @@ Caml Special Light 1.06: ------------------------ * First public release. - -$Id$ diff --git a/INSTALL b/INSTALL index d73657fa..0e709192 100644 --- a/INSTALL +++ b/INSTALL @@ -1,5 +1,5 @@ - Installing Objective Caml on a Unix machine - ------------------------------------------- + Installing OCaml on a Unix machine + ---------------------------------- PREREQUISITES @@ -43,18 +43,21 @@ in the config/ subdirectory. The "configure" script accepts the following options: --bindir (default: /usr/local/bin) - Directory where the binaries will be installed +-prefix (default: /usr/local) + Set the PREFIX variable used to define the defaults of the + following three options. Must be an absolute path name. --libdir (default: /usr/local/lib/ocaml) - Directory where the Caml library will be installed +-bindir (default: $(PREFIX)/bin) + Directory where the binaries will be installed. + Must be an absolute path name, or start with "$(PREFIX)" --mandir (default: /usr/local/man/man1) - Directory where the manual pages will be installed +-libdir (default: $(PREFIX)/lib/ocaml) + Directory where the OCaml library will be installed + Must be an absolute path name, or start with "$(PREFIX)" --prefix (default: /usr/local) - Set bindir, libdir and mandir to - /bin, /lib/ocaml, /man/man1 respectively. +-mandir (default: $(PREFIX)/man/man1) + Directory where the manual pages will be installed + Must be an absolute path name, or start with "$(PREFIX)" -cc (default: gcc if available, cc otherwise) C compiler to use for building the system @@ -67,10 +70,11 @@ The "configure" script accepts the following options: -host (default: determined automatically) The type of the host machine, in GNU's "configuration name" - format (CPU-COMPANY-SYSTEM). This info is generally determined - automatically by the "configure" script, and rarely ever - needs to be provided by hand. The installation instructions - for gcc or emacs contain a complete list of configuration names. + format (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM). + This info is generally determined automatically by the + "configure" script, and rarely ever needs to be provided by + hand. The installation instructions for gcc or emacs contain a + complete list of configuration names. -x11include (default: determined automatically) -x11lib (default: determined automatically) @@ -119,10 +123,24 @@ The "configure" script accepts the following options: run-time system manually written in assembly language. This assembler must preprocess its input with the C preprocessor. +-with-debug-runtime + Compile and install the debug version of the runtimes, useful + for debugging C stubs and other low-level code. + -verbose Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. +-no-camlp4 + Do not compile Camlp4. + +-no-graph + Do not compile the Graphics library. + +-partialld (default: determined automatically) + The linker and options to use for producing an object file + (rather than an executable) from several other object files. + Examples: Standard installation in /usr/{bin,lib,man} instead of /usr/local: @@ -130,6 +148,8 @@ Examples: Installation in /usr, man pages in section "l": ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl + 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: @@ -142,7 +162,7 @@ Examples: ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" On a Linux x86/64 bits host, to build the run-time system in PIC mode - (enables putting the runtime in a shared library, + (enables putting the runtime in a shared library, at a small performance cost): ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC" @@ -166,15 +186,15 @@ for guidance on how to edit the generated files by hand. make world -This builds the Objective Caml bytecode compiler for the first time. -This phase is fairly verbose; consider redirecting the output to a file: +This builds the OCaml bytecode compiler for the first time. This +phase is fairly verbose; consider redirecting the output to a file: make world > log.world 2>&1 # in sh make world >& log.world # in csh 3- (Optional) To be sure everything works well, you can try to -bootstrap the system --- that is, to recompile all Objective Caml -sources with the newly created compiler. From the top directory, do: +bootstrap the system --- that is, to recompile all OCaml sources with +the newly created compiler. From the top directory, do: make bootstrap @@ -201,9 +221,9 @@ or: make opt > log.opt 2>&1 # in sh make opt >& log.opt # in csh -5- Compile fast versions of the Objective Caml compilers, by -compiling them with the native-code compiler (you have only compiled -them to bytecode so far). Just do: +5- Compile fast versions of the OCaml compilers, by compiling them +with the native-code compiler (you have only compiled them to bytecode +so far). Just do: make opt.opt @@ -222,7 +242,7 @@ An alternative, and faster approach to steps 2 to 5 is The result is equivalent to "make world opt opt.opt", but this may fail if anything goes wrong in native-code generation. -6- You can now install the Objective Caml system. This will create the +6- You can now install the OCaml system. This will create the following commands (in the binary directory selected during autoconfiguration): @@ -233,9 +253,9 @@ autoconfiguration): ocamllex the lexer generator ocaml the interactive, toplevel-based system ocamlmktop a tool to make toplevel systems that integrate - user-defined C primitives and Caml code + user-defined C primitives and OCaml code ocamldebug the source-level replay debugger - ocamldep generator of "make" dependencies for Caml sources + ocamldep generator of "make" dependencies for OCaml sources ocamldoc documentation generator ocamlprof execution count profiler ocamlcp the bytecode compiler in profiling mode @@ -255,8 +275,8 @@ From the top directory, become superuser and do: directory, do "make clean". 8- (Optional) The emacs/ subdirectory contains Emacs-Lisp files for an -Objective Caml editing mode and an interface for the debugger. To -install these files, change to the emacs/ subdirectory and do +OCaml editing mode and an interface for the debugger. To install +these files, change to the emacs/ subdirectory and do make EMACSDIR= install or @@ -267,7 +287,7 @@ In the latter case, the destination directory defaults to the 9- After installation, do *not* strip the ocamldebug and ocamlbrowser executables. (These are mixed-mode executables, containing both -compiled C code and Caml bytecode; stripping erases the bytecode!) +compiled C code and OCaml bytecode; stripping erases the bytecode!) Other executables such as ocamlrun can safely be stripped. IF SOMETHING GOES WRONG: diff --git a/Makefile b/Makefile index 912259b7..73894ea2 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -31,6 +31,9 @@ CAMLRUN=byterun/ocamlrun SHELL=/bin/sh MKDIR=mkdir -p +CAMLP4OUT=$(CAMLP4:=out) +CAMLP4OPT=$(CAMLP4:=opt) + INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel @@ -40,11 +43,11 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ OPTUTILS=$(UTILS) -PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \ +PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo -TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.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 \ @@ -52,8 +55,8 @@ TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.cmo \ typing/typedtree.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/stypes.cmo typing/typecore.cmo \ + typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ + typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -71,7 +74,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 \ @@ -113,6 +116,7 @@ OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ utils/config.cmo utils/clflags.cmo \ typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \ + utils/warnings.cmo parsing/location.cmo \ typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \ bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo @@ -130,7 +134,7 @@ defaultentry: # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc + otherlibraries ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc # Compile everything the first time world: @@ -141,6 +145,7 @@ world: world.opt: $(MAKE) coldstart $(MAKE) opt.opt + $(MAKE) ocamltoolsopt # Hard bootstrap how-to: # (only necessary in some cases, for example if you remove some primitive) @@ -259,16 +264,17 @@ opt: $(MAKE) ocamlopt $(MAKE) libraryopt $(MAKE) otherlibrariesopt + $(MAKE) ocamltoolsopt $(MAKE) ocamlbuildlib.native # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \ - otherlibrariesopt \ - ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt + $(DEBUGGER) ocamldoc ocamlbuild.byte $(CAMLP4OUT) \ + ocamlopt.opt otherlibrariesopt ocamllex.opt ocamltoolsopt.opt \ + ocamldoc.opt ocamlbuild.native $(CAMLP4OPT) base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \ + ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc ocamlopt.opt \ otherlibrariesopt # Installation @@ -278,8 +284,9 @@ install: if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi if test -d $(MANDIR)/man$(MANEXT); then : ; \ else $(MKDIR) $(MANDIR)/man$(MANEXT); fi + cp VERSION $(LIBDIR)/ cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ - dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \ + dllthreads.so dllunix.so dllgraphics.so dllstr.so \ dlltkanim.so cd byterun; $(MAKE) install cp ocamlc $(BINDIR)/ocamlc$(EXE) @@ -320,6 +327,7 @@ installopt: then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE); else :; fi if test -f lex/ocamllex.opt; \ then cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE); else :; fi + cd tools; $(MAKE) installopt clean:: partialclean @@ -382,6 +390,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ + -e 's|%%ARCMD%%|$(ARCMD)|' \ -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \ -e 's|%%ARCH%%|$(ARCH)|' \ -e 's|%%MODEL%%|$(MODEL)|' \ @@ -392,6 +401,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%EXT_DLL%%|.so|' \ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -423,16 +433,6 @@ partialclean:: beforedepend:: parsing/lexer.ml -# The auxiliary lexer for counting line numbers - -parsing/linenum.ml: parsing/linenum.mll - $(CAMLLEX) parsing/linenum.mll - -partialclean:: - rm -f parsing/linenum.ml - -beforedepend:: parsing/linenum.ml - # The bytecode compiler compiled with the native-code compiler ocamlc.opt: $(COMPOBJS:.cmo=.cmx) @@ -627,6 +627,9 @@ clean:: ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi cd tools; $(MAKE) all +ocamltoolsopt: ocamlopt + cd tools; $(MAKE) opt + ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi cd tools; $(MAKE) opt.opt @@ -686,7 +689,7 @@ alldepend:: # Camlp4 -camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte +camlp4out: ocamlc ocamlbuild.byte ./build/camlp4-byte-only.sh camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native @@ -694,19 +697,20 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native # Ocamlbuild -ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot +ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot ./build/ocamlbuild-byte-only.sh -ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot +ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot ./build/ocamlbuild-native-only.sh -ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot +ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot ./build/ocamlbuildlib-native-only.sh -ocamlbuild-mixed-boot: ocamlc otherlibraries +ocamlbuild-mixed-boot: ocamlc ./build/mixed-boot.sh + touch ocamlbuild-mixed-boot partialclean:: - rm -rf _build + rm -rf _build ocamlbuild-mixed-boot # Check that the stack limit is reasonable. @@ -717,6 +721,11 @@ checkstack: fi @rm -f tools/checkstack +# Make clean in the test suite + +clean:: + cd testsuite; $(MAKE) clean + # Make MacOS X package package-macosx: @@ -762,8 +771,8 @@ distclean: .PHONY: coreboot defaultentry depend distclean install installopt .PHONY: library library-cross libraryopt ocamlbuild-mixed-boot .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc -.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt -.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt +.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt package-macosx promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt diff --git a/Makefile.nt b/Makefile.nt index a7e34f59..0b9e4e7c 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -28,6 +28,9 @@ CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun +CAMLP4OUT=$(CAMLP4:=out) +CAMLP4OPT=$(CAMLP4:=opt) + INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel @@ -37,11 +40,11 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ OPTUTILS=$(UTILS) -PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \ +PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo -TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.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 \ @@ -110,9 +113,9 @@ OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ utils/config.cmo utils/clflags.cmo \ typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \ + utils/warnings.cmo parsing/location.cmo \ typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \ - bytecomp/dll.cmo \ - bytecomp/symtable.cmo toplevel/expunge.cmo + bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree @@ -121,7 +124,8 @@ defaultentry: @echo "Please refer to the installation instructions in file README.win32." # Recompile the system using the bootstrap compiler -all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte camlp4out $(DEBUGGER) win32gui +all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ + otherlibraries ocamldoc.byte ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -211,7 +215,7 @@ opt: opt-core otherlibrariesopt ocamlbuildlib.native # Native-code versions of the tools opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ - ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt + ocamltoolsopt.opt ocamlbuild.native $(CAMLP4OPT) ocamldoc.opt # Complete build using fast compilers world.opt: coldstart opt.opt @@ -239,7 +243,6 @@ installbyt: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \ else :; fi - cd win32caml ; $(MAKE) install ./build/partial-install.sh cp config/Makefile $(LIBDIR)/Makefile.config cp README $(DISTRIB)/Readme.general.txt @@ -323,6 +326,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ + -e 's|%%ARCMD%%|$(ARCMD)|' \ -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \ -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \ -e "s|%%ARCH%%|$(ARCH)|" \ @@ -334,6 +338,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%EXT_DLL%%|.dll|" \ -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%ASM_CFI_SUPPORTED%%|false|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -366,16 +371,6 @@ partialclean:: beforedepend:: parsing/lexer.ml -# The auxiliary lexer for counting line numbers - -parsing/linenum.ml: parsing/linenum.mll - $(CAMLLEX) parsing/linenum.mll - -partialclean:: - rm -f parsing/linenum.ml - -beforedepend:: parsing/linenum.ml - # The bytecode compiler compiled with the native-code compiler ocamlc.opt: $(COMPOBJS:.cmo=.cmx) @@ -442,15 +437,13 @@ partialclean:: beforedepend:: asmcomp/arch.ml ifeq ($(TOOLCHAIN),msvc) -ASMCOMP_PROC=asmcomp/$(ARCH)/proc_nt.ml ASMCOMP_EMIT=asmcomp/$(ARCH)/emit_nt.mlp else -ASMCOMP_PROC=asmcomp/$(ARCH)/proc.ml ASMCOMP_EMIT=asmcomp/$(ARCH)/emit.mlp endif -asmcomp/proc.ml: $(ASMCOMP_PROC) - cp $(ASMCOMP_PROC) asmcomp/proc.ml +asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml + cp asmcomp/$(ARCH)/proc.ml asmcomp/proc.ml partialclean:: rm -f asmcomp/proc.ml @@ -626,14 +619,6 @@ ocamlbuild-mixed-boot: partialclean:: rm -rf _build -# The Win32 toplevel GUI - -win32gui: - cd win32caml ; $(MAKE) all - -clean:: - cd win32caml ; $(MAKE) clean - # Default rules .SUFFIXES: .ml .mli .cmo .cmi .cmx @@ -664,4 +649,18 @@ depend: beforedepend alldepend:: depend +distclean: + ./build/distclean.sh + +.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean +.PHONY: partialclean beforedepend alldepend cleanboot coldstart +.PHONY: compare core coreall +.PHONY: coreboot defaultentry depend distclean install installopt +.PHONY: library library-cross libraryopt ocamlbuild-mixed-boot +.PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt +.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: otherlibrariesopt promote promote-cross +.PHONY: restore runtime runtimeopt makeruntimeopt world world.opt + include .depend diff --git a/README b/README index 5933521d..6090041f 100644 --- a/README +++ b/README @@ -1,17 +1,17 @@ OVERVIEW: -Objective Caml is an implementation of the ML language, based on -the Caml Light dialect extended with a complete class-based object system -and a powerful module system in the style of Standard ML. - -Objective Caml comprises two compilers. One generates bytecode -which is then interpreted by a C program. This compiler runs quickly, -generates compact code with moderate memory requirements, and is -portable to essentially any 32 or 64 bit Unix platform. Performance of -generated programs is quite good for a bytecoded implementation. -This compiler can be used either as a standalone, batch-oriented -compiler that produces standalone programs, or as an interactive, -toplevel-based system. +OCaml is an implementation of the ML language, based on the Caml Light +dialect extended with a complete class-based object system and a +powerful module system in the style of Standard ML. + +OCaml comprises two compilers. One generates bytecode which is then +interpreted by a C program. This compiler runs quickly, generates +compact code with moderate memory requirements, and is portable to +essentially any 32 or 64 bit Unix platform. Performance of generated +programs is quite good for a bytecoded implementation. This compiler +can be used either as a standalone, batch-oriented compiler that +produces standalone programs, or as an interactive, toplevel-based +system. The other compiler generates high-performance native code for a number of processors. Compilation takes longer and generates bigger code, but @@ -19,31 +19,27 @@ the generated programs deliver excellent performance, while retaining the moderate memory requirements of the bytecode compiler. The native-code compiler currently runs on the following platforms: -Tier 1 (actively used and maintained by the core Caml team): +Tier 1 (actively used and maintained by the core OCaml team): AMD64 (Opteron) Linux, MacOS X, MS Windows IA32 (Pentium) Linux, FreeBSD, MacOS X, MS Windows - PowerPC MacOS X + PowerPC Linux, MacOS X + ARM Linux Tier 2 (maintained when possible, with help from users): - Alpha Digital Unix/Compaq Tru64, Linux, all BSD AMD64 FreeBSD, OpenBSD - HP PA-RISC HPUX 11, Linux IA32 (Pentium) NetBSD, OpenBSD, Solaris 9 - IA64 Linux, FreeBSD - MIPS IRIX 6 - PowerPC Linux, NetBSD - SPARC Solaris 9, Linux, NetBSD - Strong ARM Linux + PowerPC NetBSD + SPARC Solaris, Linux, NetBSD Other operating systems for the processors above have not been tested, but the compiler may work under other operating systems with little work. -Before the introduction of objects, Objective Caml was known as Caml -Special Light. Objective Caml is almost upwards compatible with Caml -Special Light, except for a few additional reserved keywords that have -forced some renaming of standard library functions. +Before the introduction of objects, OCaml was known as Caml Special +Light. OCaml is almost upwards compatible with Caml Special Light, +except for a few additional reserved keywords that have forced some +renaming of standard library functions. CONTENTS: @@ -52,7 +48,7 @@ CONTENTS: LICENSE license and copyright notice Makefile main Makefile README this file - README.win32 infos on the MS Windows ports of O.Caml + README.win32 infos on the MS Windows ports of OCaml asmcomp/ native-code compiler and linker asmrun/ native-code runtime library boot/ bootstrap compiler @@ -62,7 +58,7 @@ CONTENTS: config/ autoconfiguration stuff debugger/ source-level replay debugger driver/ driver code for the compilers - emacs/ Caml editing mode and debugger interface for GNU Emacs + emacs/ OCaml editing mode and debugger interface for GNU Emacs lex/ lexer generator maccaml/ the Macintosh GUI ocamldoc/ documentation generator @@ -79,8 +75,9 @@ COPYRIGHT: All files marked "Copyright INRIA" in this distribution are copyright 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -2007, 2008 Institut National de Recherche en Informatique et en Automatique -(INRIA) and distributed under the conditions stated in file LICENSE. +2007, 2008, 2009, 2010, 2011, 2012 Institut National de Recherche en +Informatique et en Automatique (INRIA) and distributed under the +conditions stated in file LICENSE. INSTALLATION: @@ -89,24 +86,24 @@ MacOS X machines. For MS Windows, see README.win32. DOCUMENTATION: -The Objective Caml manual is distributed in HTML, PDF, Postscript, -DVI, and Emacs Info files. It is available on the World Wide Web, at +The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and +Emacs Info files. It is available on the World Wide Web, at http://caml.inria.fr/ AVAILABILITY: -The complete Objective Caml distribution can be accessed at +The complete OCaml distribution can be accessed at http://caml.inria.fr/ KEEPING IN TOUCH WITH THE CAML COMMUNITY: -There exists a mailing list of users of the Caml implementations +There exists a mailing list of users of the OCaml implementations developed at INRIA. The purpose of this list is to share experience, exchange ideas (and even code), and report on applications -of the Caml language. Messages can be written in English or in -French. The list has about 750 subscribers. +of the OCaml language. Messages can be written in English or in +French. The list has more than 1000 subscribers. Messages to the list should be sent to: @@ -114,13 +111,13 @@ Messages to the list should be sent to: You can subscribe to this list via the Web interface at - http://yquem.inria.fr/cgi-bin/mailman/listinfo/caml-list + https://sympa-roc.inria.fr/wws/info/caml-list -Archives of the list are available on the Web site http://caml.inria.fr/ +Archives of the list are available on the Web site above. The Usenet news groups comp.lang.ml and comp.lang.functional also contains discussions about the ML family of programming languages, -including Caml. +including OCaml. BUG REPORTS AND USER FEEDBACK: diff --git a/README.win32 b/README.win32 index 27ee0851..6f21ecb5 100644 --- a/README.win32 +++ b/README.win32 @@ -1,9 +1,11 @@ - Release notes on the MS Windows ports of Objective Caml - ------------------------------------------------------- + Release notes on the MS Windows ports of OCaml + ---------------------------------------------- -There are no less than four ports of Objective Caml for MS Windows available: +There are no less than four ports of OCaml for MS Windows available: - a native Win32 port, built with the Microsoft development tools; - - a native Win32 port, built with the Cygwin/MinGW development tools; + - a native Win32 port, built with the 32-bit version of the gcc + compiler from the mingw-w64 project, packaged in Cygwin + (under the name mingw64-i686); - a port consisting of the Unix sources compiled under the Cygwin Unix-like environment for Windows; - a native Win64 port (64-bit Windows), built with the Microsoft @@ -57,7 +59,7 @@ runs without any additional tools. The native-code compiler (ocamlopt) requires the Microsoft Windows SDK (item [1]) and the flexdll tool (item [2]). -Statically linking Caml bytecode with C code (ocamlc -custom) also requires +Statically linking OCaml bytecode with C code (ocamlc -custom) also requires items [1] and [2]. The LablTk GUI requires Tcl/Tk 8.5 (item [3]). @@ -85,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.23 or later. +[2] flexdll version 0.29 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 @@ -104,7 +106,8 @@ You will need the following software components to perform the recompilation: Make sure to install the 32-bit version of TCL/TK, even if you are compiling on a 64-bit Windows. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ - Install at least the following packages: diffutils, make, ncurses. + Install at least the following packages (and their dependencies): + diffutils, 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] @@ -119,13 +122,14 @@ to adjust the paths accordingly. Then enter the following commands: cd "%PFPATH%\Microsoft Visual Studio 9.0\VC\bin" + set FLEXDLLDIR=%PFPATH%\flexdll vcvars32 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv 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 INCLUDE="%INCLUDE%;%FLEXDLLDIR%;C:\Tcl\include" >>C:\cygwin\tmp\msenv + echo FLPATH="`cygpath '%FLEXDLLDIR%'`" >>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 @@ -171,22 +175,15 @@ Unix/GCC or Cygwin or Mingw on similar hardware. CREDITS: -The initial port of Caml Special Light (the ancestor of Objective Caml) -to Windows NT was done by Kevin Gallo at Microsoft Research, who -kindly contributed his changes to the Caml project. - -The graphical user interface for the toplevel was initially developed -by Jacob Navia, then significantly improved by Christopher A. Watford. +The initial port of Caml Special Light (the ancestor of OCaml) to +Windows NT was done by Kevin Gallo at Microsoft Research, who kindly +contributed his changes to the OCaml project. ------------------------------------------------------------------------------ The native Win32 port built with Mingw -------------------------------------- -NOTE: Due to changes in cygwin's compilers, this port is not available -in OCaml 3.12.1. A patch will be made available soon after the release -of 3.12.1. - REQUIREMENTS: This port runs under MS Windows Vista, XP, and 2000. @@ -195,18 +192,34 @@ The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. The native-code compiler (ocamlopt), as well as static linking of -Caml bytecode with C code (ocamlc -custom), require +OCaml bytecode with C code (ocamlc -custom), require the Cygwin development tools, available at http://www.cygwin.com/ and the flexdll tool, available at http://alain.frisch.fr/flexdll.html You will need to install at least the following Cygwin packages (use the Setup tool from Cygwin): -binutils, gcc-core, gcc-mingw-core, mingw-runtime, w32api. -Do *not* install the Mingw/MSYS development tools from www.mingw.org: -these are not compatible with this Caml port (@responsefile not -recognized on the command line). + mingw64-i686-binutils + mingw64-i686-gcc + mingw64-i686-runtime + + +NOTE: + - There is another 32-bit gcc compiler, from the MinGW.org + project, packaged in Cygwin under the name mingw-gcc. + It is not currently supported by flexdll and OCaml. + + - The standard gcc compiler shipped with Cygwin used to + support a "-mno-cygwin" option, which turned the compiler + into a mingw compiler. This option was used + by previous versions of flexdll and OCaml, but it is no + longer available in recent version, hence the switch + to another toolchain packaged in Cygwin. + + - The standalone mingw toolchain from the MinGW-w64 project + (http://mingw-w64.sourceforge.net/) is not supported. + Please use the version packaged in Cygwin instead. The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available as part of the ActiveTCL distribution at @@ -235,14 +248,19 @@ RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, or Vista. - Cygwin: http://sourceware.cygnus.com/cygwin/ - Install at least the following packages: binutils, diffutils, - gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32api. + Install at least the following packages: + mingw64-i686-binutils + mingw64-i686-gcc + mingw64-i686-runtime + diffutils + make + ncurses - TCL/TK version 8.5 (see above). - The flexdll tool (see above). -Do *not* install the standalone distribution of MinGW, nor the -companion MSYS tools: these have problems with long command lines. -Instead, use the version of MinGW provided by Cygwin. +The standalone mingw toolchain from the MinGW-w64 project +(http://mingw-w64.sourceforge.net/) is not supported. Please use the +version packaged in Cygwin instead. Start a Cygwin shell and unpack the source distribution (ocaml-X.YY.Z.tar.gz) with "tar xzf". Change to the top-level @@ -275,8 +293,8 @@ NOTES: ------------------------------------------------------------------------------ - The Cygwin port of Objective Caml - --------------------------------- + The Cygwin port of OCaml + ------------------------ REQUIREMENTS: @@ -323,7 +341,7 @@ Windows 7 64 on Intel64/AMD64 machines. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. -Statically linking Caml bytecode with C code (ocamlc -custom) requires the +Statically linking OCaml bytecode with C code (ocamlc -custom) requires the Microsoft Platform SDK compiler (item [1] in the section "third-party software" below) and the flexdll tool (item [2]). @@ -345,7 +363,7 @@ THIRD-PARTY SOFTWARE: http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". -[2] flexdll version 0.23 or later. +[2] flexdll version 0.29 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html diff --git a/VERSION b/VERSION index e34a5e1e..c3a421f7 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -3.12.1 +4.00.0+dev15_2012-04-16 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/_tags b/_tags index 052d8aee..82c7c649 100644 --- a/_tags +++ b/_tags @@ -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. # +# # +######################################################################### + # Ocamlbuild tags file true: -traverse diff --git a/asmcomp/.cvsignore b/asmcomp/.cvsignore deleted file mode 100644 index 31d00178..00000000 --- a/asmcomp/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -emit.ml -arch.ml -proc.ml -selection.ml -reload.ml -scheduling.ml diff --git a/asmcomp/.ignore b/asmcomp/.ignore new file mode 100644 index 00000000..31d00178 --- /dev/null +++ b/asmcomp/.ignore @@ -0,0 +1,6 @@ +emit.ml +arch.ml +proc.ml +selection.ml +reload.ml +scheduling.ml diff --git a/asmcomp/alpha/arch.ml b/asmcomp/alpha/arch.ml deleted file mode 100644 index 52d1f11b..00000000 --- a/asmcomp/alpha/arch.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Specific operations for the Alpha processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Addressing modes *) - -type addressing_mode = - Ibased of string * int (* symbol + displ *) - | Iindexed of int (* reg + displ *) - -(* Specific operations *) - -type specific_operation = - Iadd4 | Iadd8 | Isub4 | Isub8 (* Scaled adds and subs *) - | Ireloadgp of bool (* The ldgp instruction *) - | Itrunc32 (* Truncate 64-bit int to 32 bit *) - -(* Sizes, endianness *) - -let big_endian = false - -let size_addr = 8 -let size_int = 8 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed 0 - -let offset_addressing addr delta = - match addr with - Ibased(s, n) -> Ibased(s, n + delta) - | Iindexed n -> Iindexed(n + delta) - -let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - match addr with - | Ibased(s, n) -> - fprintf ppf "\"%s\"%s" s - (if n <> 0 then Printf.sprintf " + %i" n else "") - | Iindexed n -> - fprintf ppf "%a%s" printreg arg.(0) - (if n <> 0 then Printf.sprintf " + %i" n else "") - -let print_specific_operation printreg op ppf arg = - match op with - | Iadd4 -> fprintf ppf "%a * 4 + %a" printreg arg.(0) printreg arg.(1) - | Iadd8 -> fprintf ppf "%a * 8 + %a" printreg arg.(0) printreg arg.(1) - | Isub4 -> fprintf ppf "%a * 4 - %a" printreg arg.(0) printreg arg.(1) - | Isub8 -> fprintf ppf "%a * 8 - %a" printreg arg.(0) printreg arg.(1) - | Ireloadgp _ -> fprintf ppf "ldgp" - | Itrunc32 -> fprintf ppf "truncate32 %a" printreg arg.(0) - -(* Distinguish between the Digital assembler and other assemblers (e.g. gas) *) - -let digital_asm = - match Config.system with - "digital" -> true - | _ -> false diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp deleted file mode 100644 index 6857da04..00000000 --- a/asmcomp/alpha/emit.mlp +++ /dev/null @@ -1,861 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -module LabelSet = - Set.Make(struct type t = Linearize.label let compare = compare end) - -(* Emission of Alpha assembly code *) - -open Location -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(* First pass: insert Iloadgp instructions where needed *) - -let insert_load_gp f = - - let labels_needing_gp = ref LabelSet.empty in - let fixpoint_reached = ref false in - - let label_needs_gp lbl = - LabelSet.mem lbl !labels_needing_gp in - let opt_label_needs_gp default = function - None -> default - | Some lbl -> label_needs_gp lbl in - let set_label_needs_gp lbl = - if not (label_needs_gp lbl) then begin - fixpoint_reached := false; - labels_needing_gp := LabelSet.add lbl !labels_needing_gp - end in - - let tailrec_entry_point = new_label() in - - (* Determine if $gp is needed before an instruction. - [next] says whether $gp is needed just after (i.e. by the following - instruction). *) - let instr_needs_gp next = function - Lend -> false - | Lop(Iconst_int n) -> (* for large n, turned into ldq ($gp) *) - next || n < Nativeint.of_int(-0x80000000) - || n > Nativeint.of_int 0x7FFFFFFF - | Lop(Iconst_float s) -> true (* turned into ldq ($gp) *) - | Lop(Iconst_symbol s) -> true (* turned into ldq ($gp) *) - | Lop(Icall_ind) -> false (* does ldgp if needed afterwards *) - | Lop(Icall_imm s) -> true (* does lda $27, *) - | Lop(Itailcall_ind) -> false - | Lop(Itailcall_imm s) -> - if s = f.fun_name then label_needs_gp tailrec_entry_point else true - | Lop(Iextcall(_, _)) -> true (* does lda $27, *) - | Lop(Iload(_, Ibased(_, _))) -> true (* loads address from ($gp) *) - | Lop(Istore(_, Ibased(_, _))) -> true (* loads address from ($gp) *) - | Lop(Iintop(Idiv | Imod)) -> true (* divq and remq can be turned into *) - | Lop(Iintop_imm((Idiv | Imod), _)) -> true (* a function call *) - | Lop(Iintop_imm(_, n)) -> (* for large n, turned into ldq ($gp) *) - next || n < -0x80000000 || n > 0x7FFFFFFF - | Lop _ -> next - | Lreloadretaddr -> next - | Lreturn -> false - | Llabel lbl -> if next then set_label_needs_gp lbl; next - | Lbranch lbl -> label_needs_gp lbl - | Lcondbranch(tst, lbl) -> next || label_needs_gp lbl - | Lcondbranch3(lbl1, lbl2, lbl3) -> - opt_label_needs_gp next lbl1 || - opt_label_needs_gp next lbl2 || - opt_label_needs_gp next lbl3 - | Lswitch lblv -> true - | Lsetuptrap lbl -> label_needs_gp lbl - | Lpushtrap -> next - | Lpoptrap -> next - | Lraise -> false in - - let rec needs_gp i = - if i.desc = Lend - then false - else instr_needs_gp (needs_gp i.next) i.desc in - - while not !fixpoint_reached do - fixpoint_reached := true; - if needs_gp f.fun_body then set_label_needs_gp tailrec_entry_point - done; - - (* Insert Ireloadgp instructions after calls where needed *) - let rec insert_reload_gp i = - if i.desc = Lend then (i, false) else begin - let (new_next, needs_next) = insert_reload_gp i.next in - let new_instr = - match i.desc with - (* If the instruction destroys $gp and $gp is needed afterwards, - insert a ldgp after the instructions. *) - Lop(Icall_ind | Icall_imm _) when needs_next -> - {i with next = - instr_cons (Lop(Ispecific(Ireloadgp true))) [||] [||] new_next } - | Lop(Iextcall(_, false)) | Lsetuptrap _ when needs_next -> - {i with next = - instr_cons (Lop(Ispecific(Ireloadgp false))) [||] [||] new_next } - | _ -> - {i with next = new_next} in - (new_instr, instr_needs_gp needs_next i.desc) - end in - - let (new_body, uses_gp) = insert_reload_gp f.fun_body in - ({f with fun_body = new_body}, uses_gp) - -(* Second pass: code generation proper *) - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Output a label *) - -let emit_label lbl = - emit_string "$"; emit_int lbl - -let emit_Llabel fallthrough lbl = - if (not fallthrough) then begin - emit_string " .align 4\n" - end ; - emit_label lbl - -(* Output a symbol *) - -let emit_symbol s = - Emitaux.emit_symbol '$' s - -(* Output a pseudo-register *) - -let emit_reg r = - match r.loc with - Reg r -> emit_string (register_name r) - | _ -> fatal_error "Emit_alpha.emit_reg" - -(* Layout of the stack frame *) - -let stack_offset = ref 0 - -let frame_size () = - let size = - !stack_offset + - 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + - (if !contains_calls then 8 else 0) in - Misc.align size 16 - -let slot_offset loc cl = - match loc with - Incoming n -> frame_size() + n - | Local n -> - if cl = 0 - then !stack_offset + n * 8 - else !stack_offset + (num_stack_slots.(0) + n) * 8 - | Outgoing n -> n - -(* Output a stack reference *) - -let emit_stack r = - match r.loc with - Stack s -> - let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)` - | _ -> fatal_error "Emit_alpha.emit_stack" - -(* Output an addressing mode *) - -let emit_addressing addr r n = - match addr with - Iindexed ofs -> - `{emit_int ofs}({emit_reg r.(n)})` - | Ibased(s, ofs) -> - `{emit_symbol s}`; - if ofs > 0 then ` + {emit_int ofs}`; - if ofs < 0 then ` - {emit_int(-ofs)}` - -(* Immediate operands *) - -let is_immediate n = digital_asm || (n >= 0 && n <= 255) - -(* Communicate live registers at call points to the assembler *) - -let int_reg_number = [| - 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; - 16; 17; 18; 19; 20; 21; 22 -|] - -let float_reg_number = [| - 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; - 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30 -|] - -let liveregs instr extra_msk = - (* $13, $14, $15 always live *) - let int_mask = ref(0x00070000 lor extra_msk) - and float_mask = ref 0 in - let add_register = function - {loc = Reg r; typ = (Int | Addr)} -> - int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r))) - | {loc = Reg r; typ = Float} -> - float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100))) - | _ -> () in - Reg.Set.iter add_register instr.live; - Array.iter add_register instr.arg; - emit_printf " .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask - -let live_24 = 1 lsl (31 - 24) -let live_25 = 1 lsl (31 - 25) -let live_26 = 1 lsl (31 - 26) -let live_27 = 1 lsl (31 - 27) - -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - lbl - -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:` - -let emit_frame fd = - ` .quad {emit_label fd.fd_lbl}\n`; - ` .word {emit_int fd.fd_frame_size}\n`; - ` .word {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .word {emit_int n}\n`) - fd.fd_live_offset; - ` .align 3\n` - -(* Record calls to the GC -- we've moved them out of the way *) - -type gc_call = - { gc_lbl: label; (* Entry label *) - gc_return_lbl: label; (* Where to branch after GC *) - gc_frame: label; (* Label of frame descriptor *) - gc_instr: instruction } (* Record live registers *) - -let call_gc_sites = ref ([] : gc_call list) - -let emit_call_gc gc = - `{emit_label gc.gc_lbl}:`; - liveregs gc.gc_instr 0; - ` bsr $26, caml_call_gc\n`; - (* caml_call_gc preserves $gp *) - `{emit_label gc.gc_frame}: br {emit_label gc.gc_return_lbl}\n` - -(* Name of readonly data section *) - -let rdata_section = - match Config.system with - "digital" -> ".rdata" - | "linux" | "openbsd" | "netbsd" | "freebsd" | "gnu" -> ".section .rodata" - | _ -> assert false - -(* Names of various instructions *) - -let name_for_int_operation = function - Iadd -> "addq" - | Isub -> "subq" - | Imul -> "mulq" - | Idiv -> "divq" - | Imod -> "remq" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "sll" - | Ilsr -> "srl" - | Iasr -> "sra" - | _ -> Misc.fatal_error "Emit.name_for_int_operation" - -let name_for_float_operation = function - Inegf -> "fneg" - | Iabsf -> "fabs" - | Iaddf -> "addt" - | Isubf -> "subt" - | Imulf -> "mult" - | Idivf -> "divt" - | _ -> Misc.fatal_error "Emit.name_for_float_operation" - -let name_for_specific_operation = function - Iadd4 -> "s4addq" - | Iadd8 -> "s8addq" - | Isub4 -> "s4subq" - | Isub8 -> "s8subq" - | _ -> Misc.fatal_error "Emit.name_for_specific_operation" - -let name_for_int_comparison = function - Isigned Ceq -> "cmpeq", true | Isigned Cne -> "cmpeq", false - | Isigned Cle -> "cmple", true | Isigned Cgt -> "cmple", false - | Isigned Clt -> "cmplt", true | Isigned Cge -> "cmplt", false - | Iunsigned Ceq -> "cmpeq", true | Iunsigned Cne -> "cmpeq", false - | Iunsigned Cle -> "cmpule", true | Iunsigned Cgt -> "cmpule", false - | Iunsigned Clt -> "cmpult", true | Iunsigned Cge -> "cmpult", false - -(* Used for comparisons against 0 *) -let name_for_int_cond_branch = function - Isigned Ceq -> "beq" | Isigned Cne -> "bne" - | Isigned Cle -> "ble" | Isigned Cgt -> "bgt" - | Isigned Clt -> "blt" | Isigned Cge -> "bge" - | Iunsigned Ceq -> "beq" | Iunsigned Cne -> "bne" - | Iunsigned Cle -> "beq" | Iunsigned Cgt -> "bne" - | Iunsigned Clt -> "#" | Iunsigned Cge -> "br" - (* Always false *) (* Always true *) - -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> ("cmpteq", false, neg) | Cne -> ("cmpteq", false, not neg) - | Cle -> ("cmptle", false, neg) | Cgt -> ("cmptlt", true, neg) - | Clt -> ("cmptlt", false, neg) | Cge -> ("cmptle", true, neg) - -(* Output the assembly code for an instruction *) - -(* Name of current function *) -let function_name = ref "" -(* Entry point for tail recursive calls *) -let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 -(* List of floating-point and big integer literals - (fon non-Digital assemblers) *) -let float_constants = ref ([] : (label * string) list) -let bigint_constants = ref ([] : (label * nativeint) list) - -let emit_instr fallthrough i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src.loc, dst.loc) with - (Reg rs, Reg rd) -> - if src.typ = Float then - ` fmov {emit_reg src}, {emit_reg dst}\n` - else - ` mov {emit_reg src}, {emit_reg dst}\n` - | (Reg rs, Stack sd) -> - if src.typ = Float then - ` stt {emit_reg src}, {emit_stack dst}\n` - else - ` stq {emit_reg src}, {emit_stack dst}\n` - | (Stack ss, Reg rd) -> - if src.typ = Float then - ` ldt {emit_reg dst}, {emit_stack src}\n` - else - ` ldq {emit_reg dst}, {emit_stack src}\n` - | _ -> - fatal_error "Emit_alpha: Imove" - end - | Lop(Iconst_int n) -> - if n = 0n then - ` clr {emit_reg i.res.(0)}\n` - else if digital_asm || - (n >= Nativeint.of_int (-0x80000000) && - n <= Nativeint.of_int 0x7FFFFFFF) then - ` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n` - else begin - (* Work around a bug in gas/gld concerning big integer constants *) - let lbl = new_label() in - bigint_constants := (lbl, n) :: !bigint_constants; - ` lda $25, {emit_label lbl}\n`; - ` ldq {emit_reg i.res.(0)}, 0($25)\n` - end - | Lop(Iconst_float s) -> - if digital_asm then - ` ldit {emit_reg i.res.(0)}, {emit_string s}\n` - else if Int64.bits_of_float (float_of_string s) = 0L then - ` fmov $f31, {emit_reg i.res.(0)}\n` - else begin - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; - ` lda $25, {emit_label lbl}\n`; - ` ldt {emit_reg i.res.(0)}, 0($25)\n` - end - | Lop(Iconst_symbol s) -> - ` lda {emit_reg i.res.(0)}, {emit_symbol s}\n` - | Lop(Icall_ind) -> - liveregs i 0; - ` mov {emit_reg i.arg.(0)}, $27\n`; - ` jsr ({emit_reg i.arg.(0)})\n`; - `{record_frame i.live}\n` - | Lop(Icall_imm s) -> - liveregs i 0; - ` jsr {emit_symbol s}\n`; - `{record_frame i.live}\n` - | Lop(Itailcall_ind) -> - let n = frame_size() in - if !contains_calls then - ` ldq $26, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` lda $sp, {emit_int n}($sp)\n`; - ` mov {emit_reg i.arg.(0)}, $27\n`; - liveregs i (live_26 + live_27); - ` jmp ({emit_reg i.arg.(0)})\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then begin - ` br {emit_label !tailrec_entry_point}\n` - end else begin - let n = frame_size() in - if !contains_calls then - ` ldq $26, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` lda $sp, {emit_int n}($sp)\n`; - ` lda $27, {emit_symbol s}\n`; - liveregs i (live_26 + live_27); - ` br {emit_symbol s}\n` - end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - ` lda $25, {emit_symbol s}\n`; - liveregs i live_25; - ` bsr $26, caml_c_call\n`; - `{record_frame i.live}\n` - end else begin - ` jsr {emit_symbol s}\n` - end - | Lop(Istackoffset n) -> - ` lda $sp, {emit_int (-n)}($sp)\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - let load_instr = - match chunk with - | Byte_unsigned -> "ldbu" - | Byte_signed -> "ldb" - | Sixteen_unsigned -> "ldwu" - | Sixteen_signed -> "ldw" - | Thirtytwo_unsigned -> "ldl" - | Thirtytwo_signed -> "ldl" - | Word -> "ldq" - | Single -> "lds" - | Double -> "ldt" - | Double_u -> "ldt" in - ` {emit_string load_instr} {emit_reg dest}, {emit_addressing addr i.arg 0}\n`; - if chunk = Thirtytwo_unsigned then - ` zapnot {emit_reg dest}, 15, {emit_reg dest}\n` - | Lop(Istore(chunk, addr)) -> - let store_instr = - match chunk with - | Byte_unsigned | Byte_signed -> "stb" - | Sixteen_unsigned | Sixteen_signed -> "stw" - | Thirtytwo_unsigned | Thirtytwo_signed -> "stl" - | Word -> "stq" - | Single -> "sts" - | Double -> "stt" - | Double_u -> "stt" in - ` {emit_string store_instr} {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame; - gc_instr = i } :: !call_gc_sites; - `{emit_label lbl_redo}: lda $13, -{emit_int n}($13)\n`; - ` cmpult $13, $14, $25\n`; - ` bne $25, {emit_label lbl_call_gc}\n`; - ` addq $13, 8, {emit_reg i.res.(0)}\n` - end else begin - begin match n with - 16 -> liveregs i 0; - ` bsr $26, caml_alloc1\n` - | 24 -> liveregs i 0; - ` bsr $26, caml_alloc2\n` - | 32 -> liveregs i 0; - ` bsr $26, caml_alloc3\n` - | _ -> ` ldiq $25, {emit_int n}\n`; - liveregs i live_25; - ` bsr $26, caml_allocN\n` - end; - (* $gp preserved by caml_alloc* *) - `{record_frame i.live} addq $13, 8, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop(Icomp cmp)) -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; - if not test then - ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` - | Lop(Iintop(Icheckbound)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` cmpule {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; - ` bne $25, {emit_label !range_check_trap}\n` - | Lop(Iintop op) -> - let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - if n = 1 lsl (Misc.log2 n) then begin - let l = Misc.log2 n in - if is_immediate n then - ` addq {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n` - else begin - ` ldiq $25, {emit_int(n-1)}\n`; - ` addq {emit_reg i.arg.(0)}, $25, $25\n` - end; - ` cmovge {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, $25\n`; - ` sra $25, {emit_int l}, {emit_reg i.res.(0)}\n` - end else begin - (* divq with immediate arg is incorrectly assembled in Tru64 5.1, - so emulate it ourselves *) - ` ldiq $25, {emit_int n}\n`; - ` divq {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Imod, n)) -> - if n = 1 lsl (Misc.log2 n) then begin - if is_immediate n then - ` and {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n` - else begin - ` ldiq $25, {emit_int (n-1)}\n`; - ` and {emit_reg i.arg.(0)}, $25, $25\n` - end; - ` subq $25, {emit_int n}, $24\n`; - ` cmovge {emit_reg i.arg.(0)}, $25, $24\n`; - ` cmoveq $25, $25, $24\n`; - ` mov $24, {emit_reg i.res.(0)}\n` - end else begin - (* remq with immediate arg is incorrectly assembled in Tru64 5.1, - so emulate it ourselves *) - ` ldiq $25, {emit_int n}\n`; - ` remq {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Ilsl, 1)) -> - (* Turn x << 1 into x + x, slightly faster according to the docs *) - ` addq {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; - if not test then - ` xor {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n` - - | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` cmpule {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; - ` bne $25, {emit_label !range_check_trap}\n` - | Lop(Iintop_imm(op, n)) -> - let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` - | Lop(Inegf | Iabsf as op) -> - let instr = name_for_float_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> - let instr = name_for_float_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Ifloatofint) -> - ` .set noat\n`; - ` lda $sp, -8($sp)\n`; - ` stq {emit_reg i.arg.(0)}, 0($sp)\n`; - ` ldt $f28, 0($sp)\n`; - ` cvtqt $f28, {emit_reg i.res.(0)}\n`; - ` lda $sp, 8($sp)\n`; - ` .set at\n` - | Lop(Iintoffloat) -> - ` .set noat\n`; - ` lda $sp, -8($sp)\n`; - ` cvttqc {emit_reg i.arg.(0)}, $f28\n`; - ` stt $f28, 0($sp)\n`; - ` ldq {emit_reg i.res.(0)}, 0($sp)\n`; - ` lda $sp, 8($sp)\n`; - ` .set at\n` - | Lop(Ispecific(Ireloadgp marked_r26)) -> - ` ldgp $gp, 0($26)\n`; - if marked_r26 then - ` bic $gp, 1, $gp\n` - | Lop(Ispecific Itrunc32) -> - ` addl {emit_reg i.arg.(0)}, 0, {emit_reg i.res.(0)}\n` - | Lop(Ispecific sop) -> - let instr = name_for_specific_operation sop in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lreloadretaddr -> - let n = frame_size() in - ` ldq $26, {emit_int(n - 8)}($sp)\n` - | Lreturn -> - let n = frame_size() in - if n > 0 then - ` lda $sp, {emit_int n}($sp)\n`; - liveregs i live_26; - ` ret ($26)\n` - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` br {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - ` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Ifalsetest -> - ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Iinttest cmp -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`; - if test then - ` bne $25, {emit_label lbl}\n` - else - ` beq $25, {emit_label lbl}\n` - | Iinttest_imm(cmp, 0) -> - let branch = name_for_int_cond_branch cmp in - ` {emit_string branch} {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - let (comp, test) = name_for_int_comparison cmp in - ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, $25\n`; - if test then - ` bne $25, {emit_label lbl}\n` - else - ` beq $25, {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - ` .set noat\n`; - let (comp, swap, test) = name_for_float_comparison cmp neg in - ` {emit_string comp} `; - if swap - then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f28\n` - else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f28\n`; - if test - then ` fbeq $f28, {emit_label lbl}\n` - else ` fbne $f28, {emit_label lbl}\n`; - ` .set at\n` - | Ioddtest -> - ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n` - | Ieventest -> - ` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - begin match lbl0 with - None -> () - | Some lbl -> ` beq {emit_reg i.arg.(0)}, {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` blbs {emit_reg i.arg.(0)}, {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> - if lbl0 <> None then - ` blbc {emit_reg i.arg.(0)}, {emit_label lbl}\n` - else if lbl1 <> None then - ` bne {emit_reg i.arg.(0)}, {emit_label lbl}\n` - else begin - ` subq {emit_reg i.arg.(0)}, 2, $25\n`; - ` beq $25, {emit_label lbl}\n` - end - end - | Lswitch jumptbl -> - let lbl_jumptbl = new_label() in - ` lda $25, {emit_label lbl_jumptbl}\n`; - ` s4addq {emit_reg i.arg.(0)}, $25, $25\n`; - ` ldl $25, 0($25)\n`; - ` addq $gp, $25, $25\n`; - ` jmp ($25), {emit_label jumptbl.(0)}\n`; - ` {emit_string rdata_section}\n`; - `{emit_label lbl_jumptbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .gprel32 {emit_label jumptbl.(i)}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` br $25, {emit_label lbl}\n` - | Lpushtrap -> - stack_offset := !stack_offset + 16; - ` lda $sp, -16($sp)\n`; - ` stq $15, 0($sp)\n`; - ` stq $25, 8($sp)\n`; - ` mov $sp, $15\n` - | Lpoptrap -> - ` ldq $15, 0($sp)\n`; - ` lda $sp, 16($sp)\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - ` ldq $26, 8($15)\n`; - ` mov $15, $sp\n`; - ` ldq $15, 0($sp)\n`; - ` lda $sp, 16($sp)\n`; - liveregs i live_26; - ` jmp $25, ($26)\n` (* Keep retaddr in $25 for debugging *) - -let rec emit_all fallthrough i = match i.desc with -| Lend -> () -| _ -> - emit_instr fallthrough i; - emit_all (has_fallthrough i.desc) i.next - -(* Emission of a function declaration *) - -let emit_fundecl (fundecl, needs_gp) = - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - stack_offset := 0; - call_gc_sites := []; - range_check_trap := 0; - float_constants := []; - bigint_constants := []; - ` .text\n`; - ` .align 4\n`; - ` .globl {emit_symbol fundecl.fun_name}\n`; - ` .ent {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; - if needs_gp then begin - ` .set noreorder\n`; - ` ldgp $gp, 0($27)\n`; - ` .set reorder\n` - end; - let n = frame_size() in - if n > 0 then - ` lda $sp, -{emit_int n}($sp)\n`; - if !contains_calls then begin - ` stq $26, {emit_int(n - 8)}($sp)\n`; - ` .mask 0x04000000, -8\n`; - ` .fmask 0x0, 0\n` - end; - ` .frame $sp, {emit_int n}, $26\n`; - ` .prologue {emit_int(if needs_gp then 1 else 0)}\n`; - tailrec_entry_point := new_label(); - `{emit_label !tailrec_entry_point}:\n`; - emit_all true fundecl.fun_body; - List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then begin - `{emit_label !range_check_trap}:\n`; - ` br $26, caml_ml_array_bound_error\n` - (* Keep retaddr in $26 for debugging *) - end; - ` .end {emit_symbol fundecl.fun_name}\n`; - if !bigint_constants <> [] then begin - ` {emit_string rdata_section}\n`; - ` .align 3\n`; - List.iter - (fun (lbl, n) -> `{emit_label lbl}: .quad 0x{emit_string(Nativeint.format "%x" n)}\n`) - !bigint_constants - end; - if !float_constants <> [] then begin - ` {emit_string rdata_section}\n`; - ` .align 3\n`; - List.iter - (fun (lbl, s) -> `{emit_label lbl}: .t_floating {emit_string s}\n`) - !float_constants - end - -let fundecl f = - emit_fundecl (insert_load_gp f) - -(* Emission of data *) - -let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .word {emit_int n}\n` - | Cint32 n -> - let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in - ` .long {emit_nativeint n'}\n` - | Cint n -> - if digital_asm then - ` .quad {emit_nativeint n}\n` - else - (* Work around a bug in gas regarding the parsing of - long decimal constants *) - ` .quad 0x{emit_string(Nativeint.format "%x" n)}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_directive ".quad" f - | Csymbol_address s -> - ` .quad {emit_symbol s}\n` - | Clabel_address lbl -> - ` .quad {emit_label (100000 + lbl)}\n` - | Cstring s -> - emit_string_directive " .ascii " s - | Cskip n -> - if n > 0 then ` .space {emit_int n}\n` - | Calign n -> - ` .align {emit_int(Misc.log2 n)}\n` - -let data l = - ` .data\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - (* There are really two groups of registers: - $sp and $15 always point to stack locations - $0 - $14, $16-$23 never point to stack locations. *) - ` .noalias $0,$sp; .noalias $0,$15; .noalias $1,$sp; .noalias $1,$15\n`; - ` .noalias $2,$sp; .noalias $2,$15; .noalias $3,$sp; .noalias $3,$15\n`; - ` .noalias $4,$sp; .noalias $4,$15; .noalias $5,$sp; .noalias $5,$15\n`; - ` .noalias $6,$sp; .noalias $6,$15; .noalias $7,$sp; .noalias $7,$15\n`; - ` .noalias $8,$sp; .noalias $8,$15; .noalias $9,$sp; .noalias $9,$15\n`; - ` .noalias $10,$sp; .noalias $10,$15; .noalias $11,$sp; .noalias $11,$15\n`; - ` .noalias $12,$sp; .noalias $12,$15; .noalias $13,$sp; .noalias $13,$15\n`; - ` .noalias $14,$sp; .noalias $14,$15; .noalias $16,$sp; .noalias $16,$15\n`; - ` .noalias $17,$sp; .noalias $17,$15; .noalias $18,$sp; .noalias $18,$15\n`; - ` .noalias $19,$sp; .noalias $19,$15; .noalias $20,$sp; .noalias $20,$15\n`; - ` .noalias $21,$sp; .noalias $21,$15; .noalias $22,$sp; .noalias $22,$15\n`; - ` .noalias $23,$sp; .noalias $23,$15\n\n`; - (* The following .file directive is intended to prevent the generation - of line numbers for the debugger, 'cos they make .o files larger - and slow down linking. *) - ` .file 1 \"{emit_string !Location.input_name}\"\n\n`; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n` - -let end_assembly () = - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .data\n`; - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .quad 0\n`; - let lbl_frame = Compilenv.make_symbol (Some "frametable") in - ` {emit_string rdata_section}\n`; - ` .globl {emit_symbol lbl_frame}\n`; - `{emit_symbol lbl_frame}:\n`; - ` .quad {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml deleted file mode 100644 index 93c2422f..00000000 --- a/asmcomp/alpha/proc.ml +++ /dev/null @@ -1,217 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Description of the Alpha processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Instruction selection *) - -let word_addressed = true - -(* Registers available for register allocation *) - -(* Register map: - $0 - $7 0 - 7 function results - $8 - $12 8 - 12 general purpose ($9 - $15 are preserved by C) - $13 allocation pointer - $14 allocation limit - $15 trap pointer - $16 - $22 13 - 19 function arguments - $23 - $25 temporaries (for the code gen and for the asm) - $26 - $30 stack ptr, global ptr, etc - $31 always zero - - $f0 - $f7 100 - 107 function results - $f8 - $f15 108 - 115 general purpose ($f2 - $f9 preserved by C) - $f16 - $f23 116 - 123 function arguments - $f24 - $f30 124 - 129 general purpose - $f28 temporary - $f31 always zero *) - -let int_reg_name = [| - (* 0-7 *) "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; - (* 8-12 *) "$8"; "$9"; "$10"; "$11"; "$12"; - (* 13-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22" -|] - -let float_reg_name = [| - (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7"; - (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15"; - (* 116-123 *) "$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21"; "$f22"; "$f23"; - (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f29"; "$f30" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 20; 30 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 20 Reg.dummy in - for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 30 Reg.dummy in - for i = 0 to 29 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float make_stack - arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 13 18 116 123 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 13 18 116 123 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 7 100 107 not_supported res in loc - -(* On the Alpha, C functions have calling conventions similar to those - for Caml functions, except that integer and floating-point registers - for arguments are allocated "in sequence". E.g. a function - taking a float f1 and two ints i2 and i3 will put f1 in the - first float reg, i2 in the second int reg and i3 in the third int reg. *) - -let ext_calling_conventions first_int last_int first_float last_float - make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; incr int; incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; incr int; incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let loc_external_arguments arg = - ext_calling_conventions 13 18 116 121 outgoing arg -let loc_external_results res = - let (loc, ofs) = ext_calling_conventions 0 0 100 100 not_supported res in loc -let extcall_use_push = false - -let loc_exn_bucket = phys_reg 0 (* $0 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* $9 - $12, $f2 - $f9 preserved *) - Array.of_list(List.map phys_reg - [0;1;2;3;4;5;6;7;8;13;14;15;16;17;18;19; - 100;101;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124; - 125;126;127;128;129]) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 4 - | _ -> 19 -let max_register_pressure = function - Iextcall(_, _) -> [| 4; 8 |] - | _ -> [| 19; 29 |] - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - let as_cmd = - if digital_asm && !Clflags.gprofile - then Config.asm ^ " -pg" - else Config.asm in - Ccomp.command (as_cmd ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/alpha/reload.ml b/asmcomp/alpha/reload.ml deleted file mode 100644 index 53f7b183..00000000 --- a/asmcomp/alpha/reload.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Reloading for the Alpha *) - -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/alpha/scheduling.ml b/asmcomp/alpha/scheduling.ml deleted file mode 100644 index f59c26ed..00000000 --- a/asmcomp/alpha/scheduling.ml +++ /dev/null @@ -1,70 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -open Arch -open Mach - -(* The Digital Unix assembler does scheduling better than us. - However, the Linux-Alpha assembler does not do scheduling, so we do - a feeble attempt here. *) - -class scheduler = object (self) - -inherit Schedgen.scheduler_generic as super - -(* Latencies (in cycles). Based on the 21064, with some poetic license. *) - -method oper_latency = function - Ireload -> 3 - | Iload(_, _) -> 3 - | Iconst_symbol _ -> 3 (* turned into a load *) - | Iconst_float _ -> 3 (* ends up in a load *) - | Iintop(Imul) -> 23 - | Iintop_imm(Imul, _) -> 23 - | Iaddf -> 6 - | Isubf -> 6 - | Imulf -> 6 - | Idivf -> 63 - | _ -> 2 - (* Most arithmetic instructions can be executed back-to-back in 1 cycle. - However, some combinations (arith; load or arith; store) require 2 - cycles. Also, by claiming 2 cycles instead of 1, we might favor - dual issue. *) - -(* Issue cycles. Rough approximations. *) - -method oper_issue_cycles = function - Iconst_float _ -> 4 (* load from $gp, then load *) - | Ialloc _ -> 4 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 3 - | Iintop_imm(Imod, _) -> 5 - | Iintop_imm(Icheckbound, _) -> 2 - | Ifloatofint -> 10 - | Iintoffloat -> 10 - | _ -> 1 - -(* Say that reloadgp is not part of a basic block (prevents moving it - past an operation that uses $gp) *) - -method oper_in_basic_block = function - Ispecific(Ireloadgp _) -> false - | op -> super#oper_in_basic_block op - -end - -let fundecl = - if digital_asm - then (fun f -> f) - else (new scheduler)#schedule_fundecl diff --git a/asmcomp/alpha/selection.ml b/asmcomp/alpha/selection.ml deleted file mode 100644 index d91ec5bd..00000000 --- a/asmcomp/alpha/selection.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Instruction selection for the Alpha processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -class selector = object (self) - -inherit Selectgen.selector_generic as super - -method is_immediate n = digital_asm || (n >= 0 && n <= 255) - -method select_addressing = function - (* Force an explicit lda for non-scheduling assemblers, - this allows our scheduler to do a better job. *) - Cconst_symbol s when digital_asm -> - (Ibased(s, 0), Ctuple []) - | Cop((Cadda | Caddi), [Cconst_symbol s; Cconst_int n]) when digital_asm -> - (Ibased(s, n), Ctuple []) - | Cop((Cadda | Caddi), [arg; Cconst_int n]) -> - (Iindexed n, arg) - | Cop((Cadda | Caddi), [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) - | arg -> - (Iindexed 0, arg) - -method! select_operation op args = - match (op, args) with - (* Recognize shift-add operations *) - ((Caddi|Cadda), - [arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) -> - (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> - (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> - (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2]) - | (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) -> - (Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2]) - | (Csubi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) -> - (Ispecific(if mult = 4 then Isub4 else Isub8), [arg1; arg2]) - (* Recognize truncation/normalization of 64-bit integers to 32 bits *) - | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) -> - (Ispecific Itrunc32, [arg]) - (* Work around various limitations of the GNU assembler *) - | ((Caddi|Cadda), [arg1; Cconst_int n]) - when not (self#is_immediate n) && self#is_immediate (-n) -> - (Iintop_imm(Isub, -n), [arg1]) - | (Cdivi, [arg1; Cconst_int n]) - when (not digital_asm) && n <> 1 lsl (Misc.log2 n) -> - (Iintop Idiv, args) - | (Cmodi, [arg1; Cconst_int n]) - when (not digital_asm) && n <> 1 lsl (Misc.log2 n) -> - (Iintop Imod, args) - | _ -> - super#select_operation op args - -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index 3e8f4b11..8e065d9a 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -51,6 +51,10 @@ let size_addr = 8 let size_int = 8 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = true + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index a33a0fa9..7dd55c96 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -23,11 +23,8 @@ open Mach open Linearize open Emitaux -let macosx = - match Config.system with - | "macosx" -> true - | _ -> false - +let macosx = (Config.system = "macosx") +let mingw64 = (Config.system = "mingw64") (* Tradeoff between code size and code speed *) @@ -64,17 +61,17 @@ let emit_symbol s = Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode && not macosx + if !Clflags.dlcode && not macosx && not mingw64 then `call {emit_symbol s}@PLT` else `call {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode && not macosx + if !Clflags.dlcode && not macosx && not mingw64 then `jmp {emit_symbol s}@PLT` else `jmp {emit_symbol s}` let load_symbol_addr s = - if !Clflags.dlcode + if !Clflags.dlcode && not mingw64 then `movq {emit_symbol s}@GOTPCREL(%rip)` else if !pic_code then `leaq {emit_symbol s}(%rip)` @@ -85,6 +82,9 @@ let load_symbol_addr s = let emit_label lbl = emit_string ".L"; emit_int lbl +let emit_data_label lbl = + emit_string ".Ld"; emit_int lbl + (* Output a .align directive. *) let emit_align n = @@ -317,11 +317,17 @@ let emit_float_test cmp neg arg lbl = (* Deallocate the stack frame before a return or tail call *) -let output_epilogue () = +let output_epilogue f = if frame_required() then begin let n = frame_size() - 8 in - ` addq ${emit_int n}, %rsp\n` + ` addq ${emit_int n}, %rsp\n`; + cfi_adjust_cfa_offset (-n); + f (); + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n end + else + f () (* Output the assembly code for an instruction *) @@ -332,7 +338,9 @@ 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; match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> @@ -373,14 +381,16 @@ let emit_instr fallthrough i = ` {emit_call s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> - output_epilogue(); + output_epilogue begin fun () -> ` jmp *{emit_reg i.arg.(0)}\n` + end | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin - output_epilogue(); + output_epilogue begin fun () -> ` {emit_jump s}\n` + end end | Lop(Iextcall(s, alloc)) -> if alloc then begin @@ -394,6 +404,7 @@ let emit_instr fallthrough i = if n < 0 then ` addq ${emit_int(-n)}, %rsp\n` else ` subq ${emit_int(n)}, %rsp\n`; + cfi_adjust_cfa_offset n; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in @@ -536,8 +547,9 @@ let emit_instr fallthrough i = | Lreloadretaddr -> () | Lreturn -> - output_epilogue(); + output_epilogue begin fun () -> ` ret\n` + end | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> @@ -601,9 +613,12 @@ let emit_instr fallthrough i = ` movslq ({emit_reg tmp1}, {emit_reg i.arg.(0)}, 4), {emit_reg tmp2}\n`; ` addq {emit_reg tmp2}, {emit_reg tmp1}\n`; ` jmp *{emit_reg tmp1}\n`; - if macosx - then ` .const\n` - else ` .section .rodata\n`; + if macosx then + ` .const\n` + else if mingw64 then + ` .section .rdata,\"dr\"\n` + else + ` .section .rodata\n`; emit_align 4; `{emit_label lbl}:`; for i = 0 to Array.length jumptbl - 1 do @@ -613,12 +628,16 @@ let emit_instr fallthrough i = | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> + cfi_adjust_cfa_offset 8; ` pushq %r14\n`; + cfi_adjust_cfa_offset 8; ` movq %rsp, %r14\n`; stack_offset := !stack_offset + 16 | Lpoptrap -> ` popq %r14\n`; + cfi_adjust_cfa_offset (-8); ` addq $8, %rsp\n`; + cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug then begin @@ -650,7 +669,7 @@ let emit_profile () = | "linux" | "gnu" -> (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly and rbx, rbp, r12-r15 like all C functions. - We need to preserve r10 and r11 ourselves, since Caml can + We need to preserve r10 and r11 ourselves, since OCaml can use them for argument passing. *) ` pushq %r10\n`; ` movq %rsp, %rbp\n`; @@ -682,15 +701,19 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc (); if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 in - ` subq ${emit_int n}, %rsp\n` + ` subq ${emit_int n}, %rsp\n`; + cfi_adjust_cfa_offset n; end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); + cfi_endproc (); begin match Config.system with "linux" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; @@ -698,9 +721,12 @@ let fundecl fundecl = | _ -> () end; if !float_constants <> [] then begin - if macosx - then ` .literal8\n` - else ` .section .rodata.cst8,\"a\",@progbits\n`; + 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 @@ -712,7 +738,7 @@ let emit_item = function | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` + `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -728,7 +754,7 @@ let emit_item = function | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> - ` .quad {emit_label (100000 + lbl)}\n` + ` .quad {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> @@ -746,9 +772,11 @@ let begin_assembly() = if !Clflags.dlcode then begin (* from amd64.S; could emit these constants on demand *) if macosx then - ` .literal16\n` + ` .literal16\n` + else if mingw64 then + ` .section .rdata,\"dr\"\n` else - ` .section .rodata.cst8,\"a\",@progbits\n`; + ` .section .rodata.cst8,\"a\",@progbits\n`; emit_align 16; `{emit_symbol "caml_negf_mask"}: .quad 0x8000000000000000, 0\n`; emit_align 16; diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 724d6ee0..6dbbb83e 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -80,6 +80,9 @@ let add_used_symbol s = let emit_label lbl = emit_string "L"; emit_int lbl +let emit_data_label lbl = + emit_string "Ld"; emit_int lbl + (* Output a .align directive. *) let emit_align n = @@ -591,19 +594,24 @@ let emit_instr fallthrough i = end | Lswitch jumptbl -> let lbl = new_label() in - if !pic_code then begin - ` lea r11, {emit_label lbl}\n`; - ` jmp QWORD PTR [r11+{emit_reg i.arg.(0)}*8]\n` - end else begin - ` jmp QWORD PTR [{emit_reg i.arg.(0)}*8 + {emit_label lbl}]\n` - end; - ` .DATA\n`; - emit_align 8; - `{emit_label lbl} LABEL QWORD\n`; + (* rax and rdx are clobbered by the Lswitch, + meaning that no variable that is live across the Lswitch + is assigned to rax or rdx. However, the argument to Lswitch + can still be assigned to one of these two registers, so + we must be careful not to clobber it before use. *) + let (tmp1, tmp2) = + if i.arg.(0).loc = Reg 0 (* rax *) + then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) + else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in + ` lea {emit_reg tmp1}, {emit_label lbl}\n`; + ` movsxd {emit_reg tmp2}, DWORD PTR [{emit_reg tmp1}+{emit_reg i.arg.(0)}*4]\n`; + ` add {emit_reg tmp1}, {emit_reg tmp2}\n`; + ` jmp {emit_reg tmp1}\n`; + emit_align 4; + `{emit_label lbl} LABEL DWORD\n`; for i = 0 to Array.length jumptbl - 1 do - ` QWORD {emit_label jumptbl.(i)}\n` - done; - ` .CODE\n` + ` DWORD {emit_label jumptbl.(i)} - {emit_label lbl}\n` + done | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> @@ -691,7 +699,7 @@ let emit_item = function add_def_symbol s; `{emit_symbol s} LABEL QWORD\n` | Cdefine_label lbl -> - `{emit_label (100000 + lbl)} LABEL QWORD\n` + `{emit_data_label lbl} LABEL QWORD\n` | Cint8 n -> ` BYTE {emit_int n}\n` | Cint16 n -> @@ -708,7 +716,7 @@ let emit_item = function add_used_symbol s; ` QWORD {emit_symbol s}\n` | Clabel_address lbl -> - ` QWORD {emit_label (100000 + lbl)}\n` + ` QWORD {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " BYTE " s | Cskip n -> diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 4ba0d5c3..01132e6c 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -20,13 +20,27 @@ open Cmm open Reg open Mach +(* Which ABI to use *) + +let win64 = + match Config.system with + | "win64" | "mingw64" -> true + | _ -> false + +(* Which asm conventions to use *) + +let masm = + match Config.ccomp_type with + | "msvc" -> true + | _ -> false + (* Registers available for register allocation *) (* Register map: - rax 0 rax - r11: Caml function arguments - rbx 1 rdi - r9: C function arguments - rdi 2 rax: Caml and C function results - rsi 3 rbx, rbp, r12-r15 are preserved by C + rax 0 + rbx 1 + rdi 2 + rsi 3 rdx 4 rcx 5 r8 6 @@ -39,18 +53,44 @@ open Mach r14 trap pointer r15 allocation pointer - xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments - xmm0 - xmm7: C function arguments - xmm0: Caml and C function results *) + xmm0 - xmm15 100 - 115 *) + +(* Conventions: + rax - r11: OCaml function arguments + rax: OCaml and C function results + xmm0 - xmm9: OCaml function arguments + xmm0: OCaml and C function results + Under Unix: + rdi, rsi, rdx, rcx, r8, r9: C function arguments + xmm0 - xmm7: C function arguments + rbx, rbp, r12-r15 are preserved by C + xmm registers are not preserved by C + Under Win64: + rcx, rdx, r8, r9: C function arguments + xmm0 - xmm3: C function arguments + rbx, rbp, rsi, rdi r12-r15 are preserved by C + xmm6-xmm15 are preserved by C +*) let int_reg_name = - [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; - "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |] + match Config.ccomp_type with + | "msvc" -> + [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; + "r10"; "r11"; "rbp"; "r12"; "r13" |] + | _ -> + [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; + "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |] let float_reg_name = - [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7"; - "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11"; - "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |] + match Config.ccomp_type with + | "msvc" -> + [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7"; + "xmm8"; "xmm9"; "xmm10"; "xmm11"; + "xmm12"; "xmm13"; "xmm14"; "xmm15" |] + | _ -> + [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7"; + "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11"; + "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |] let num_register_classes = 2 @@ -141,26 +181,74 @@ let loc_parameters arg = let loc_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc -(* C calling convention: +(* C calling conventions under Unix: first integer args in rdi, rsi, rdx, rcx, r8, r9 first float args in xmm0 ... xmm7 - remaining args on stack. - Return value in rax or xmm0. *) + remaining args on stack + return value in rax or xmm0. + C calling conventions under Win64: + first integer args in rcx, rdx, r8, r9 + first float args in xmm0 ... xmm3 + each integer arg consumes a float reg, and conversely + remaining args on stack + always 32 bytes reserved at bottom of stack. + Return value in rax or xmm0. *) -let loc_external_arguments arg = - calling_conventions 2 7 100 107 outgoing arg let loc_external_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc +let unix_loc_external_arguments arg = + calling_conventions 2 7 100 107 outgoing arg + +let win64_int_external_arguments = + [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |] +let win64_float_external_arguments = + [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] + +let win64_loc_external_arguments arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let reg = ref 0 + and ofs = ref 32 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !reg < 4 then begin + loc.(i) <- phys_reg win64_int_external_arguments.(!reg); + incr reg + end else begin + loc.(i) <- stack_slot (Outgoing !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !reg < 4 then begin + loc.(i) <- phys_reg win64_float_external_arguments.(!reg); + incr reg + end else begin + loc.(i) <- stack_slot (Outgoing !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let loc_external_arguments = + if win64 then win64_loc_external_arguments else unix_loc_external_arguments + let loc_exn_bucket = rax (* Registers destroyed by operations *) -let destroyed_at_c_call = (* rbp, rbx, r12-r15 preserved *) - Array.of_list(List.map phys_reg - [0;2;3;4;5;6;7;8;9; - 100;101;102;103;104;105;106;107; - 108;109;110;111;112;113;114;115]) +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;8;9; + 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;8;9; + 100;101;102;103;104;105;106;107; + 108;109;110;111;112;113;114;115]) let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs @@ -177,11 +265,11 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_,_) -> 0 + Iextcall(_,_) -> if win64 then 8 else 0 | _ -> 11 let max_register_pressure = function - Iextcall(_, _) -> [| 4; 0 |] + Iextcall(_, _) -> if win64 then [| 8; 10 |] else [| 4; 0 |] | Iintop(Idiv | Imod) -> [| 11; 16 |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) -> [| 12; 16 |] @@ -196,5 +284,10 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + if masm then + Ccomp.command (Config.asm ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ + (if !Clflags.verbose then "" else ">NUL")) + else + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) diff --git a/asmcomp/amd64/proc_nt.ml b/asmcomp/amd64/proc_nt.ml deleted file mode 100644 index 5c90e4f5..00000000 --- a/asmcomp/amd64/proc_nt.ml +++ /dev/null @@ -1,233 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Description of the AMD64 processor with Win64 conventions *) - -open Misc -open Arch -open Cmm -open Reg -open Mach - -(* Registers available for register allocation *) - -(* Register map: - rax 0 rax - r11: Caml function arguments - rbx 1 rcx - r9: C function arguments - rdi 2 rax: Caml and C function results - rsi 3 rbx, rbp, rsi, rdi r12-r15 are preserved by C - rdx 4 - rcx 5 - r8 6 - r9 7 - r10 8 - r11 9 - rbp 10 - r12 11 - r13 12 - r14 trap pointer - r15 allocation pointer - - xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments - xmm0 - xmm3: C function arguments - xmm0: Caml and C function results - xmm6-xmm15 are preserved by C *) - -let int_reg_name = - [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; - "r10"; "r11"; "rbp"; "r12"; "r13" |] - -let float_reg_name = - [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7"; - "xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 13; 16 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -(* Pack registers starting at %rax so as to reduce the number of REX - prefixes and thus improve code density *) -let rotate_registers = false - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 13 Reg.dummy in - for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 16 Reg.dummy in - for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let rax = phys_reg 0 -let rcx = phys_reg 5 -let rdx = phys_reg 4 -let r11 = phys_reg 9 -let rxmm15 = phys_reg 115 - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Instruction selection *) - -let word_addressed = false - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float make_stack - arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 0 9 100 109 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc - -(* C calling conventions (Win64): - first integer args in rcx, rdx, r8, r9 (4 - 7) - first float args in xmm0 ... xmm3 (100 - 103) - each integer arg consumes a float reg, and conversely - remaining args on stack - always 32 bytes reserved at bottom of stack. - Return value in rax or xmm0 -*) - -let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc - -let int_external_arguments = - [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |] -let float_external_arguments = - [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] - -let loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let reg = ref 0 - and ofs = ref 32 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !reg < 4 then begin - loc.(i) <- phys_reg int_external_arguments.(!reg); - incr reg - end else begin - loc.(i) <- stack_slot (Outgoing !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !reg < 4 then begin - loc.(i) <- phys_reg float_external_arguments.(!reg); - incr reg - end else begin - loc.(i) <- stack_slot (Outgoing !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) - -let loc_exn_bucket = rax - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = - (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *) - Array.of_list(List.map phys_reg - [0;4;5;6;7;8;9; - 100;101;102;103;104;105]) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] - | Iop(Istore(Single, _)) -> [| rxmm15 |] - | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) - -> [| rax |] - | Iswitch(_, _) when !pic_code -> [| r11 |] - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_,_) -> 8 - | _ -> 11 - -let max_register_pressure = function - Iextcall(_, _) -> [| 8; 10 |] - | Iintop(Idiv | Imod) -> [| 11; 16 |] - | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) - -> [| 12; 16 |] - | Istore(Single, _) -> [| 13; 15 |] - | _ -> [| 13; 16 |] - -(* Layout of the stack frame *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ - Filename.quote infile ^ "> NUL") diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 66772de9..e7d5e23b 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/amd64/scheduling.ml b/asmcomp/amd64/scheduling.ml index faf0353e..8ba88f4a 100644 --- a/asmcomp/amd64/scheduling.ml +++ b/asmcomp/amd64/scheduling.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 4921e511..9c4464ae 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -121,7 +121,7 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n -method select_addressing exp = +method select_addressing chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) if d < -0x8000_0000 || d > 0x7FFF_FFFF @@ -157,7 +157,7 @@ method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> - begin match self#select_addressing (Cop(op, args)) with + begin match self#select_addressing Word (Cop(op, args)) with (Iindexed d, _) -> super#select_operation op args | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) @@ -191,7 +191,7 @@ method! select_operation op args = begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] when loc = loc' && self#is_immediate n -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> super#select_operation op args @@ -202,12 +202,12 @@ method! select_operation op args = method select_floatarith commutative regular_op mem_op args = match args with - [arg1; Cop(Cload (Double|Double_u), [loc2])] -> - let (addr, arg2) = self#select_addressing loc2 in + [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] -> + let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2]) - | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative -> - let (addr, arg1) = self#select_addressing loc1 in + | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative -> + let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg2; arg1]) | [arg1; arg2] -> @@ -227,9 +227,6 @@ method! insert_op_debug op dbg rs rd = with Use_default -> super#insert_op_debug op dbg rs rd -method! insert_op op rs rd = - self#insert_op_debug op Debuginfo.none rs rd - end let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index aafb094b..c4aca8df 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -1,12 +1,13 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* 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. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -17,9 +18,81 @@ open Misc open Format +type abi = EABI | EABI_VFP +type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7 +type fpu = Soft | VFPv3_D16 | VFPv3 + +let abi = + match Config.system with + "linux_eabi" -> EABI + | "linux_eabihf" -> EABI_VFP + | _ -> assert false + +let string_of_arch = function + ARMv4 -> "armv4" + | ARMv5 -> "armv5" + | ARMv5TE -> "armv5te" + | ARMv6 -> "armv6" + | ARMv6T2 -> "armv6t2" + | ARMv7 -> "armv7" + +let string_of_fpu = function + Soft -> "soft" + | VFPv3_D16 -> "vfpv3-d16" + | VFPv3 -> "vfpv3" + (* Machine-specific command-line options *) -let command_line_options = [] +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 + end in + (ref def_arch, ref def_fpu, ref def_thumb) + +let pic_code = ref false + +let farch spec = + arch := (match spec with + "armv4" when abi <> EABI_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 + | 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 + | spec -> raise (Arg.Bad spec)) + +let command_line_options = + [ "-farch", Arg.String farch, + " Select the ARM target architecture" + ^ " (default: " ^ (string_of_arch !arch) ^ ")"; + "-ffpu", Arg.String ffpu, + " Select the floating-point hardware" + ^ " (default: " ^ (string_of_fpu !fpu) ^ ")"; + "-fPIC", Arg.Set pic_code, + " Generate position-independent machine code"; + "-fno-PIC", Arg.Clear pic_code, + " Generate position-dependent machine code"; + "-fthumb", Arg.Set thumb, + " Enable Thumb/Thumb-2 code generation" + ^ (if !thumb then " (default)" else ""); + "-fno-thumb", Arg.Clear thumb, + " Disable Thumb/Thumb-2 code generation" + ^ (if not !thumb then " (default" else "")] (* Addressing modes *) @@ -37,6 +110,14 @@ 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 *) and arith_operation = Ishiftadd @@ -51,6 +132,10 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = false + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 @@ -84,3 +169,56 @@ let print_specific_operation printreg op ppf arg = fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) | Irevsubimm n -> fprintf ppf "%i %s %a" n "-" printreg arg.(0) + | Imuladd -> + fprintf ppf "(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsub -> + fprintf ppf "-(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulf -> + fprintf ppf "-f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + | Imuladdf -> + fprintf ppf "%a +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmuladdf -> + fprintf ppf "%a -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsubf -> + fprintf ppf "(-f %a) +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulsubf -> + fprintf ppf "(-f %a) -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Isqrtf -> + fprintf ppf "sqrtf %a" + printreg arg.(0) + +(* Recognize immediate operands *) + +(* Immediate operands are 8-bit immediate values, zero-extended, + and rotated right by 0 ... 30 bits. + In Thumb/Thumb-2 mode we utilize 26 ... 30. *) + +let is_immediate n = + let n = ref n in + let s = ref 0 in + let m = if !thumb then 24 else 30 in + while (!s <= m && Int32.logand !n 0xffl <> !n) do + n := Int32.logor (Int32.shift_right_logical !n 2) (Int32.shift_left !n 30); + s := !s + 2 + done; + !s <= m diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index cfcb0c94..846ee4ae 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -1,12 +1,13 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* 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. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -33,16 +34,28 @@ let fastcode_flag = ref true let emit_label lbl = emit_string ".L"; emit_int lbl -(* Output a symbol *) +let emit_data_label lbl = + emit_string ".Ld"; emit_int lbl + +(* Symbols *) let emit_symbol s = Emitaux.emit_symbol '$' s +let emit_call s = + if !Clflags.dlcode || !pic_code + then `bl {emit_symbol s}(PLT)` + else `bl {emit_symbol s}` + +let emit_jump s = + if !Clflags.dlcode || !pic_code + then `b {emit_symbol s}(PLT)` + else `b {emit_symbol s}` + (* Output a pseudo-register *) -let emit_reg r = - match r.loc with - | Reg r -> emit_string (register_name r) +let emit_reg = function + {loc = Reg r} -> emit_string (register_name r) | _ -> fatal_error "Emit_arm.emit_reg" (* Layout of the stack frame *) @@ -53,14 +66,23 @@ let frame_size () = let sz = !stack_offset + 4 * num_stack_slots.(0) + + 8 * num_stack_slots.(1) + + 8 * num_stack_slots.(2) + (if !contains_calls then 4 else 0) in Misc.align sz 8 let slot_offset loc cl = match loc with - Incoming n -> frame_size() + n - | Local n -> !stack_offset + n * 4 - | Outgoing n -> n + Incoming n -> + assert (n >= 0); + frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 4 + else !stack_offset + num_stack_slots.(0) * 4 + n * 8 + | Outgoing n -> + assert (n >= 0); + n (* Output a stack reference *) @@ -79,20 +101,13 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> - live_offset := (r lsl 1) + 1 :: !live_offset + live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) @@ -100,18 +115,57 @@ let record_frame live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:` - -let emit_frame fd = - ` .word {emit_label fd.fd_lbl} + 4\n`; - ` .short {emit_int fd.fd_frame_size}\n`; - ` .short {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .short {emit_int n}\n`) - fd.fd_live_offset; - ` .align 2\n` + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; + `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In debug mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Otherwise, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame_lbl: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) + +let bound_error_label dbg = + if !Clflags.debug || !bound_error_sites = [] then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; + bd_frame_lbl = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + let bd = List.hd !bound_error_sites in bd.bd_lbl + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame_lbl}:\n` + +(* Negate a comparison *) + +let negate_integer_comparison = function + Isigned cmp -> Isigned(negate_comparison cmp) + | Iunsigned cmp -> Iunsigned(negate_comparison cmp) (* Names of various instructions *) @@ -121,22 +175,13 @@ let name_for_comparison = function | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> if neg then "ne" else "eq" - | Cne -> if neg then "eq" else "ne" - | Cle -> if neg then "hi" else "ls" - | Cge -> if neg then "lt" else "ge" - | Clt -> if neg then "pl" else "mi" - | Cgt -> if neg then "le" else "gt" - let name_for_int_operation = function Iadd -> "add" | Isub -> "sub" | Imul -> "mul" - | Iand -> "and" - | Ior -> "orr" - | Ixor -> "eor" + | Iand -> "and" + | Ior -> "orr" + | Ixor -> "eor" | _ -> assert false let name_for_shift_operation = function @@ -145,60 +190,54 @@ let name_for_shift_operation = function | Iasr -> "asr" | _ -> assert false -let name_for_shift_int_operation = function - Ishiftadd -> "add" - | Ishiftsub -> "sub" - | Ishiftsubrev -> "rsb" - -(* Recognize immediate operands *) - -(* Immediate operands are 8-bit immediate values, zero-extended, and rotated - right by 0, 2, 4, ... 30 bits. - We check only with 8-bit values shifted left 0 to 24 bits. *) - -let rec is_immed n shift = - shift <= 24 && - (Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n - || is_immed n (shift + 2)) - -let is_immediate n = is_immed n 0 - (* General functional to decompose a non-immediate integer constant - into 8-bit chunks shifted left 0 ... 24 bits *) + into 8-bit chunks shifted left 0 ... 30 bits. *) let decompose_intconst n fn = let i = ref n in let shift = ref 0 in let ninstr = ref 0 in - while !i <> 0n do - if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then + while !i <> 0l do + if Int32.logand (Int32.shift_right !i !shift) 3l = 0l then shift := !shift + 2 else begin - let mask = Nativeint.shift_left 0xFFn !shift in - let bits = Nativeint.logand !i mask in - fn bits; + let bits = Int32.logand !i (Int32.shift_left 0xffl !shift) in + i := Int32.sub !i bits; shift := !shift + 8; - i := Nativeint.sub !i bits; - incr ninstr + incr ninstr; + fn bits end done; !ninstr (* Load an integer constant into a register *) -let emit_intconst r n = - let nr = Nativeint.lognot n in +let emit_intconst dst n = + let nr = Int32.lognot n in if is_immediate n then begin - ` mov {emit_reg r}, #{emit_nativeint n}\n`; 1 + (* Use movs here to enable 16-bit T1 encoding *) + ` movs {emit_reg dst}, #{emit_int32 n}\n`; 1 end else if is_immediate nr then begin - ` mvn {emit_reg r}, #{emit_nativeint nr}\n`; 1 + ` mvn {emit_reg dst}, #{emit_int32 nr}\n`; 1 + end else if !arch > ARMv6 then begin + let nl = Int32.logand 0xffffl n in + let nh = Int32.logand 0xffffl (Int32.shift_right_logical n 16) in + if nh = 0l then begin + ` movw {emit_reg dst}, #{emit_int32 nl}\n`; 1 + end else if Int32.logand nl 0xffl = nl then begin + ` movs {emit_reg dst}, #{emit_int32 nl}\n`; + ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2 + end else begin + ` movw {emit_reg dst}, #{emit_int32 nl}\n`; + ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2 + end end else begin let first = ref true in decompose_intconst n (fun bits -> if !first - then ` mov {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n` - else ` add {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`; + then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` + else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; first := false) end @@ -206,46 +245,105 @@ let emit_intconst r n = let emit_stack_adjustment instr n = if n <= 0 then 0 else - decompose_intconst (Nativeint.of_int n) + decompose_intconst (Int32.of_int n) (fun bits -> - ` {emit_string instr} sp, sp, #{emit_nativeint bits}\n`) + ` {emit_string instr} sp, sp, #{emit_int32 bits}\n`) (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Table of symbols referenced *) -let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) -(* Table of floating-point literals *) -let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) -(* Total space (in word) occupied by pending literals *) +(* Pending floating-point literals *) +let float_literals = ref ([] : (string * label) list) +(* Pending relative references to the global offset table *) +let gotrel_literals = ref ([] : (label * label) list) +(* Pending symbol literals *) +let symbol_literals = ref ([] : (string * label) list) +(* Total space (in words) occupied by pending literals *) let num_literals = ref 0 -(* Label a symbol or float constant *) -let label_constant tbl s size = +(* Label a floating-point literal *) +let float_literal f = try - Hashtbl.find tbl s + List.assoc f !float_literals with Not_found -> let lbl = new_label() in - Hashtbl.add tbl s lbl; - num_literals := !num_literals + size; + num_literals := !num_literals + 2; + float_literals := (f, lbl) :: !float_literals; lbl -(* Emit all pending constants *) - -let emit_constants () = - Hashtbl.iter - (fun s lbl -> - `{emit_label lbl}: .word {emit_symbol s}\n`) - symbol_constants; - Hashtbl.iter - (fun s lbl -> - `{emit_label lbl}: .double {emit_string s}\n`) - float_constants; - Hashtbl.clear symbol_constants; - Hashtbl.clear float_constants; +(* Label a GOTREL literal *) +let gotrel_literal l = + let lbl = new_label() in + num_literals := !num_literals + 1; + gotrel_literals := (l, lbl) :: !gotrel_literals; + lbl + +(* Label a symbol literal *) +let symbol_literal s = + try + List.assoc s !symbol_literals + with Not_found -> + let lbl = new_label() in + num_literals := !num_literals + 1; + symbol_literals := (s, lbl) :: !symbol_literals; + lbl + +(* Emit all pending literals *) +let emit_literals() = + if !float_literals <> [] then begin + ` .align 3\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}: .double {emit_string f}\n`) + !float_literals; + float_literals := [] + end; + if !symbol_literals <> [] then begin + let offset = if !thumb then 4 else 8 in + let suffix = if !pic_code then "(GOT)" else "" in + ` .align 2\n`; + List.iter + (fun (l, lbl) -> + `{emit_label lbl}: .word _GLOBAL_OFFSET_TABLE_-({emit_label l}+{emit_int offset})\n`) + !gotrel_literals; + List.iter + (fun (s, lbl) -> + `{emit_label lbl}: .word {emit_symbol s}{emit_string suffix}\n`) + !symbol_literals; + gotrel_literals := []; + symbol_literals := [] + end; num_literals := 0 +(* Emit code to load the address of a symbol *) + +let emit_load_symbol_addr dst s = + if !pic_code then begin + let lbl_pic = new_label() in + let lbl_got = gotrel_literal lbl_pic in + let lbl_sym = symbol_literal s in + (* Both r3 and r12 are marked as clobbered in PIC mode (cf. proc.ml), + so use r12 as temporary scratch register unless the destination is + r12, then we use r3 instead. *) + let tmp = if dst.loc = Reg 8 (*r12*) + then phys_reg 3 (*r3*) + else phys_reg 8 (*r12*) in + ` ldr {emit_reg tmp}, {emit_label lbl_got}\n`; + ` ldr {emit_reg dst}, {emit_label lbl_sym}\n`; + `{emit_label lbl_pic}: add {emit_reg tmp}, pc, {emit_reg tmp}\n`; + ` ldr {emit_reg dst}, [{emit_reg tmp}, {emit_reg dst}] @ {emit_symbol s}\n`; + 4 + end else if !arch > ARMv6 && not !Clflags.dlcode && !fastcode_flag then begin + ` movw {emit_reg dst}, #:lower16:{emit_symbol s}\n`; + ` movt {emit_reg dst}, #:upper16:{emit_symbol s}\n`; + 2 + end else begin + let lbl = symbol_literal s in + ` ldr {emit_reg dst}, {emit_label lbl} @ {emit_symbol s}\n`; + 1 + end + (* Output the assembly code for an instruction *) let emit_instr i = @@ -254,40 +352,76 @@ let emit_instr i = | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc = dst.loc then 0 else begin - match (src, dst) with - {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} -> - ` mov {emit_reg dst}, {emit_reg src}\n`; 1 - | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} -> - ` str {emit_reg src}, {emit_stack dst}\n`; 1 - | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} -> - ` ldr {emit_reg dst}, {emit_stack src}\n`; 1 + begin match (src, dst) with + {loc = Reg _; typ = Float}, {loc = Reg _} -> + ` fcpyd {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Reg _} -> + ` mov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = Float}, _ -> + ` fstd {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg _}, _ -> + ` str {emit_reg src}, {emit_stack dst}\n` + | {typ = Float}, _ -> + ` fldd {emit_reg dst}, {emit_stack src}\n` | _ -> - assert false + ` ldr {emit_reg dst}, {emit_stack src}\n` + end; 1 end | Lop(Iconst_int n) -> - emit_intconst i.res.(0) n - | Lop(Iconst_float s) -> - let bits = Int64.bits_of_float (float_of_string s) in - let high_bits = Int64.to_nativeint (Int64.shift_right_logical bits 32) - and low_bits = Int64.to_nativeint bits in - if is_immediate low_bits && is_immediate high_bits then begin - ` mov {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`; - ` mov {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`; - 2 + emit_intconst i.res.(0) (Nativeint.to_int32 n) + | Lop(Iconst_float f) when !fpu = Soft -> + ` @ {emit_string f}\n`; + let bits = Int64.bits_of_float (float_of_string f) in + let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) + and low_bits = Int64.to_int32 bits in + if is_immediate low_bits || is_immediate high_bits then begin + let ninstr_low = emit_intconst i.res.(0) low_bits + and ninstr_high = emit_intconst i.res.(1) high_bits in + ninstr_low + ninstr_high end else begin - let lbl = label_constant float_constants s 2 in - ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`; + let lbl = float_literal f in + ` ldr {emit_reg i.res.(0)}, {emit_label lbl}\n`; ` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`; 2 end + | Lop(Iconst_float f) -> + let encode imm = + let sg = Int64.to_int (Int64.shift_right_logical imm 63) in + let ex = Int64.to_int (Int64.shift_right_logical imm 52) in + let ex = (ex land 0x7ff) - 1023 in + let mn = Int64.logand imm 0xfffffffffffffL in + if Int64.logand mn 0xffffffffffffL <> 0L || ex < -3 || ex > 4 + then + None + else begin + let mn = Int64.to_int (Int64.shift_right_logical mn 48) in + if mn land 0x0f <> mn then + None + else + let ex = ((ex + 3) land 0x07) lxor 0x04 in + Some((sg lsl 7) lor (ex lsl 4) lor mn) + end in + begin match encode (Int64.bits_of_float (float_of_string f)) with + None -> + let lbl = float_literal f in + ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + | Some imm8 -> + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + end; 1 | Lop(Iconst_symbol s) -> - let lbl = label_constant symbol_constants s 1 in - ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1 + emit_load_symbol_addr i.res.(0) s | Lop(Icall_ind) -> - ` mov lr, pc\n`; - `{record_frame i.live} bx {emit_reg i.arg.(0)}\n`; 2 + if !arch >= ARMv5 then begin + ` blx {emit_reg i.arg.(0)}\n`; + `{record_frame i.live i.dbg}\n`; 1 + end else begin + ` mov lr, pc\n`; + ` bx {emit_reg i.arg.(0)}\n`; + `{record_frame i.live i.dbg}\n`; 2 + end | Lop(Icall_imm s) -> - `{record_frame i.live} bl {emit_symbol s}\n`; 1 + ` {emit_call s}\n`; + `{record_frame i.live i.dbg}\n`; 1 | Lop(Itailcall_ind) -> let n = frame_size() in if !contains_calls then @@ -303,17 +437,16 @@ let emit_instr i = if !contains_calls then ` ldr lr, [sp, #{emit_int (n-4)}]\n`; let ninstr = emit_stack_adjustment "add" n in - ` b {emit_symbol s}\n`; + ` {emit_jump s}\n`; 2 + ninstr end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - let lbl = label_constant symbol_constants s 1 in - ` ldr r12, {emit_label lbl} @ {emit_symbol s}\n`; - `{record_frame i.live} bl caml_c_call\n`; 2 - end else begin - ` bl {emit_symbol s}\n`; 1 - end + | Lop(Iextcall(s, false)) -> + ` {emit_call s}\n`; 1 + | Lop(Iextcall(s, true)) -> + let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in + ` {emit_call "caml_c_call"}\n`; + `{record_frame i.live i.dbg}\n`; + 1 + ninstr | Lop(Istackoffset n) -> assert (n mod 8 = 0); let ninstr = @@ -322,16 +455,28 @@ let emit_instr i = else emit_stack_adjustment "add" (-n) in stack_offset := !stack_offset + n; ninstr - | Lop(Iload((Double | Double_u), addr)) -> - let addr' = offset_addressing addr 4 in - if i.res.(0).loc <> i.arg.(0).loc then begin - ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`; - ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n` - end else begin - ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`; - ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - end; - 2 + | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 -> + ` 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 -> + (* Use LDM or LDRD if possible *) + begin match i.res.(0), i.res.(1), addr with + {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 + when rt < rt2 -> + ` ldm {emit_reg i.arg.(0)}, \{{emit_reg i.res.(0)}, {emit_reg i.res.(1)}}\n`; 1 + | {loc = Reg rt}, {loc = Reg rt2}, addr + when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 -> + ` ldrd {emit_reg i.res.(0)}, {emit_reg i.res.(1)}, {emit_addressing addr i.arg 0}\n`; 1 + | _ -> + let addr' = offset_addressing addr 4 in + if i.res.(0).loc <> i.arg.(0).loc then begin + ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`; + ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n` + end else begin + ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`; + ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` + end; 2 + end | Lop(Iload(size, addr)) -> let r = i.res.(0) in let instr = @@ -340,65 +485,114 @@ let emit_instr i = | Byte_signed -> "ldrsb" | Sixteen_unsigned -> "ldrh" | Sixteen_signed -> "ldrsh" + | Double + | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in - ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; - 1 - | Lop(Istore((Double | Double_u), addr)) -> - let addr' = offset_addressing addr 4 in - ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; - ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; - 2 + ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 + | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 -> + ` 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 -> + (* Use STM or STRD if possible *) + begin match i.arg.(0), i.arg.(1), addr with + {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 + when rt < rt2 -> + ` stm {emit_reg i.arg.(2)}, \{{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}}\n`; 1 + | {loc = Reg rt}, {loc = Reg rt2}, addr + when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 -> + ` strd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_addressing addr i.arg 2}\n`; 1 + | _ -> + let addr' = offset_addressing addr 4 in + ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; + ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 + end | Lop(Istore(size, addr)) -> let r = i.arg.(0) in let instr = match size with - Byte_unsigned | Byte_signed -> "strb" - | Sixteen_unsigned | Sixteen_signed -> "strh" + Byte_unsigned + | Byte_signed -> "strb" + | Sixteen_unsigned + | Sixteen_signed -> "strh" + | Double + | Double_u -> "fstd" | _ (* 32-bit quantities *) -> "str" in - ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; - 1 + ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1 | Lop(Ialloc n) -> + let lbl_frame = record_frame_label i.live i.dbg in if !fastcode_flag then begin - let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in - ` sub alloc_ptr, alloc_ptr, r12\n`; + let lbl_redo = new_label() in + `{emit_label lbl_redo}:`; + let ninstr = decompose_intconst + (Int32.of_int n) + (fun i -> + ` sub alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in ` cmp alloc_ptr, alloc_limit\n`; - `{record_frame i.live} blcc caml_call_gc\n`; ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; - 4 + ni - end else if n = 8 || n = 12 || n = 16 then begin - `{record_frame i.live} bl caml_alloc{emit_int ((n-4)/4)}\n`; - ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2 + let lbl_call_gc = new_label() in + ` bcc {emit_label lbl_call_gc}\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites; + 3 + ninstr end else begin - let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in - `{record_frame i.live} bl caml_allocN\n`; - ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; - 2 + ni + let ninstr = + begin match n with + 8 -> ` {emit_call "caml_alloc1"}\n`; 1 + | 12 -> ` {emit_call "caml_alloc2"}\n`; 1 + | 16 -> ` {emit_call "caml_alloc3"}\n`; 1 + | _ -> let ninstr = emit_intconst (phys_reg 7) (Int32.of_int n) in + ` {emit_call "caml_allocN"}\n`; 1 + ninstr + end in + `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; + 1 + ninstr end | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> let shift = name_for_shift_operation op in ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop(Icomp cmp)) -> - let comp = name_for_comparison cmp in + let compthen = name_for_comparison cmp in + let compelse = name_for_comparison (negate_integer_comparison cmp) in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` mov {emit_reg i.res.(0)}, #0\n`; - ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3 - | Lop(Iintop(Icheckbound)) -> + ` ite {emit_string compthen}\n`; + ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; + ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 + | Lop(Iintop_imm(Icomp cmp, n)) -> + let compthen = name_for_comparison cmp in + let compelse = name_for_comparison (negate_integer_comparison cmp) in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` ite {emit_string compthen}\n`; + ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; + ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` blls caml_ml_array_bound_error\n`; 2 + ` bls {emit_label lbl}\n`; 2 + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` bls {emit_label lbl}\n`; 2 + | Lop(Ispecific(Ishiftcheckbound shift)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` bcs {emit_label lbl}\n`; 2 | Lop(Iintop op) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) let l = Misc.log2 n in let r = i.res.(0) in ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; - if n <= 256 then + if n <= 256 then begin + ` it lt\n`; ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` - else begin + end else begin + ` itt lt\n`; ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; ` sublt {emit_reg r}, {emit_reg r}, #1\n` end; - ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4 + ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5 | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) let l = Misc.log2 n in let a = i.arg.(0) in @@ -409,40 +603,71 @@ let emit_instr i = ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; ` bpl {emit_label lbl}\n`; ` cmp {emit_reg r}, #0\n`; + ` it ne\n`; ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - `{emit_label lbl}:\n`; 6 + `{emit_label lbl}:\n`; 7 | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> let shift = name_for_shift_operation op in ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 - | Lop(Iintop_imm(Icomp cmp, n)) -> - let comp = name_for_comparison cmp in - ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; - ` mov {emit_reg i.res.(0)}, #0\n`; - ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3 - | Lop(Iintop_imm(Icheckbound, n)) -> - ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; - ` blls caml_ml_array_bound_error\n`; 2 | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 - | Lop(Inegf) -> (* argument and result in (r0, r1) *) - ` eor r1, r1, #0x80000000\n`; 1 - | Lop(Iabsf) -> (* argument and result in (r0, r1) *) - ` bic r1, r1, #0x80000000\n`; 1 - | Lop(Ifloatofint | Iintoffloat | Iaddf | Isubf | Imulf | Idivf) -> - assert false + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + | Lop(Iabsf | Inegf as op) when !fpu = Soft -> + let instr = (match op with + Iabsf -> "bic" + | Inegf -> "eor" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(1)}, {emit_reg i.arg.(1)}, #0x80000000\n`; 1 + | Lop(Iabsf | Inegf | Ispecific Isqrtf as op) -> + let instr = (match op with + Iabsf -> "fabsd" + | Inegf -> "fnegd" + | Ispecific Isqrtf -> "fsqrtd" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1 + | Lop(Ifloatofint) -> + ` fmsr s14, {emit_reg i.arg.(0)}\n`; + ` fsitod {emit_reg i.res.(0)}, s14\n`; 2 + | Lop(Iintoffloat) -> + ` ftosizd s14, {emit_reg i.arg.(0)}\n`; + ` fmrs {emit_reg i.res.(0)}, s14\n`; 2 + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> + let instr = (match op with + Iaddf -> "faddd" + | Isubf -> "fsubd" + | Imulf -> "fmuld" + | Idivf -> "fdivd" + | Ispecific Inegmulf -> "fnmuld" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + 1 + | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> + let instr = (match op with + Imuladdf -> "fmacd" + | Inegmuladdf -> "fnmacd" + | Imulsubf -> "fmscd" + | Inegmulsubf -> "fnmscd" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; + 1 | Lop(Ispecific(Ishiftarith(op, shift))) -> - let instr = name_for_shift_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; + let instr = (match op with + Ishiftadd -> "add" + | Ishiftsub -> "sub" + | Ishiftsubrev -> "rsb") in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; if shift >= 0 then `, lsl #{emit_int shift}\n` else `, asr #{emit_int (-shift)}\n`; 1 - | Lop(Ispecific(Ishiftcheckbound shift)) -> - ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; - ` blcs caml_ml_array_bound_error\n`; 2 | Lop(Ispecific(Irevsubimm n)) -> ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + | Lop(Ispecific(Imuladd | Imulsub as op)) -> + let instr = (match op with + Imuladd -> "mla" + | 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 | Lreloadretaddr -> let n = frame_size() in ` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1 @@ -458,29 +683,41 @@ let emit_instr i = begin match tst with Itruetest -> ` cmp {emit_reg i.arg.(0)}, #0\n`; - ` bne {emit_label lbl}\n` + ` bne {emit_label lbl}\n`; 2 | Ifalsetest -> ` cmp {emit_reg i.arg.(0)}, #0\n`; - ` beq {emit_label lbl}\n` + ` beq {emit_label lbl}\n`; 2 | Iinttest cmp -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_label lbl}\n` + ` b{emit_string comp} {emit_label lbl}\n`; 2 | Iinttest_imm(cmp, n) -> ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_label lbl}\n` + ` b{emit_string comp} {emit_label lbl}\n`; 2 | Ifloattest(cmp, neg) -> - assert false + let comp = (match (cmp, neg) with + (Ceq, false) | (Cne, true) -> "eq" + | (Cne, false) | (Ceq, true) -> "ne" + | (Clt, false) -> "cc" + | (Clt, true) -> "cs" + | (Cle, false) -> "ls" + | (Cle, true) -> "hi" + | (Cgt, false) -> "gt" + | (Cgt, true) -> "le" + | (Cge, false) -> "ge" + | (Cge, true) -> "lt") in + ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` fmstat\n`; + ` b{emit_string comp} {emit_label lbl}\n`; 3 | Ioddtest -> ` tst {emit_reg i.arg.(0)}, #1\n`; - ` bne {emit_label lbl}\n` + ` bne {emit_label lbl}\n`; 2 | Ieventest -> ` tst {emit_reg i.arg.(0)}, #1\n`; - ` beq {emit_label lbl}\n` - end; - 2 - | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` beq {emit_label lbl}\n`; 2 + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmp {emit_reg i.arg.(0)}, #1\n`; begin match lbl0 with None -> () @@ -495,107 +732,135 @@ let emit_instr i = | Some lbl -> ` bgt {emit_label lbl}\n` end; 4 - | Lswitch jumptbl -> - ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; - ` mov r0, r0\n`; (* nop *) - for i = 0 to Array.length jumptbl - 1 do - ` .word {emit_label jumptbl.(i)}\n` - done; - 2 + Array.length jumptbl + | Lswitch jumptbl -> + if !arch > ARMv6 && !thumb then begin + let lbl = new_label() in + ` tbh [pc, {emit_reg i.arg.(0)}]\n`; + `{emit_label lbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .short ({emit_label jumptbl.(i)}-{emit_label lbl})/2\n`; + done; + ` .align 1\n`; + 2 + Array.length jumptbl / 2 + end else begin + if not !pic_code then begin + ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; + ` nop\n`; + for i = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(i)}\n` + done + end else begin + (* Slightly slower, but position-independent *) + ` add pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`; + ` nop\n`; + for i = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(i)}\n` + done + end; + 2 + Array.length jumptbl + end | Lsetuptrap lbl -> ` bl {emit_label lbl}\n`; 1 | Lpushtrap -> stack_offset := !stack_offset + 8; - ` stmfd sp!, \{trap_ptr, lr}\n`; + ` push \{trap_ptr, lr}\n`; ` mov trap_ptr, sp\n`; 2 | Lpoptrap -> - ` ldmfd sp!, \{trap_ptr, lr}\n`; + ` pop \{trap_ptr, lr}\n`; stack_offset := !stack_offset - 8; 1 | Lraise -> - ` mov sp, trap_ptr\n`; - ` ldmfd sp!, \{trap_ptr, pc}\n`; 2 + if !Clflags.debug then begin + ` {emit_call "caml_raise_exn"}\n`; + `{record_frame Reg.Set.empty i.dbg}\n`; 1 + end else begin + ` mov sp, trap_ptr\n`; + ` pop \{trap_ptr, pc}\n`; 2 + end (* Emission of an instruction sequence *) -let no_fallthrough = function - Lop(Itailcall_ind | Itailcall_imm _) -> true - | Lreturn -> true - | Lbranch _ -> true - | Lswitch _ -> true - | Lraise -> true - | _ -> false - let rec emit_all ninstr i = if i.desc = Lend then () else begin let n = emit_instr i in let ninstr' = ninstr + n in - let limit = 511 - !num_literals in - if ninstr' >= limit - 64 && no_fallthrough i.desc then begin - emit_constants(); + (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *) + let limit = (if !fpu >= VFPv3_D16 && !float_literals <> [] + then 127 + else 511) in + let limit = limit - !num_literals in + if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin + emit_literals(); emit_all 0 i.next - end else - if ninstr' >= limit then begin + end else if !num_literals != 0 && ninstr' >= limit then begin let lbl = new_label() in ` b {emit_label lbl}\n`; - emit_constants(); + emit_literals(); `{emit_label lbl}:\n`; emit_all 0 i.next end else emit_all ninstr' i.next end +(* Emission of the profiling prelude *) + +let emit_profile() = + match Config.system with + "linux_eabi" | "linux_eabihf" -> + ` push \{lr}\n`; + ` {emit_call "__gnu_mcount_nc"}\n` + | _ -> () + (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); + float_literals := []; + gotrel_literals := []; + symbol_literals := []; stack_offset := 0; - Hashtbl.clear symbol_constants; - Hashtbl.clear float_constants; + call_gc_sites := []; + bound_error_sites := []; ` .text\n`; ` .align 2\n`; - ` .global {emit_symbol fundecl.fun_name}\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + if !arch > ARMv6 && !thumb then + ` .thumb\n` + else + ` .arm\n`; + ` .type {emit_symbol fundecl.fun_name}, %function\n`; `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.gprofile then emit_profile(); let n = frame_size() in ignore(emit_stack_adjustment "sub" n); if !contains_calls then ` str lr, [sp, #{emit_int(n - 4)}]\n`; `{emit_label !tailrec_entry_point}:\n`; emit_all 0 fundecl.fun_body; - emit_constants() + emit_literals(); + List.iter emit_call_gc !call_gc_sites; + List.iter emit_call_bound_error !bound_error_sites; + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n` (* Emission of data *) let emit_item = function - Cglobal_symbol s -> - ` .global {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .short {emit_int n}\n` - | Cint32 n -> - ` .word {emit_nativeint n}\n` - | Cint n -> - ` .word {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_split_directive ".long" f - | Csymbol_address s -> - ` .word {emit_symbol s}\n` - | Clabel_address lbl -> - ` .word {emit_label (100000 + lbl)}\n` - | Cstring s -> - emit_string_directive " .ascii " s - | Cskip n -> - if n > 0 then ` .space {emit_int n}\n` - | Calign n -> - ` .align {emit_int(Misc.log2 n)}\n` + Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> `{emit_symbol s}:\n` + | Cdefine_label lbl -> `{emit_data_label lbl}:\n` + | Cint8 n -> ` .byte {emit_int n}\n` + | Cint16 n -> ` .short {emit_int n}\n` + | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` + | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` + | Csingle f -> ` .single {emit_string f}\n` + | Cdouble f -> ` .double {emit_string f}\n` + | Csymbol_address s -> ` .word {emit_symbol s}\n` + | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` + | Cstring s -> emit_string_directive " .ascii " s + | Cskip n -> if n > 0 then ` .space {emit_int n}\n` + | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` let data l = ` .data\n`; @@ -604,32 +869,62 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = - `trap_ptr .req r11\n`; - `alloc_ptr .req r8\n`; - `alloc_limit .req r10\n`; + ` .syntax unified\n`; + begin match !arch with + | ARMv4 -> ` .arch armv4t\n` + | ARMv5 -> ` .arch armv5t\n` + | ARMv5TE -> ` .arch armv5te\n` + | ARMv6 -> ` .arch armv6\n` + | ARMv6T2 -> ` .arch armv6t2\n` + | ARMv7 -> ` .arch armv7-a\n` + end; + begin match !fpu with + Soft -> ` .fpu softvfp\n` + | VFPv3_D16 -> ` .fpu vfpv3-d16\n` + | VFPv3 -> ` .fpu vfpv3\n` + end; + `trap_ptr .req r8\n`; + `alloc_ptr .req r10\n`; + `alloc_limit .req r11\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; - ` .global {emit_symbol lbl_begin}\n`; + ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; - ` .global {emit_symbol lbl_begin}\n`; + ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n` let end_assembly () = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; - ` .global {emit_symbol lbl_end}\n`; + ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in ` .data\n`; - ` .global {emit_symbol lbl_end}\n`; + ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; - ` .word 0\n`; + ` .long 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in - ` .data\n`; - ` .global {emit_symbol lbl}\n`; + ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; - ` .word {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + emit_frames + { efa_label = (fun lbl -> + ` .type {emit_label lbl}, %function\n`; + ` .word {emit_label lbl}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .word {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .word {emit_label lbl} - . + {emit_int32 ofs}\n`); + efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + ` .type {emit_symbol lbl}, %object\n`; + ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; + begin match Config.system with + "linux_eabihf" | "linux_eabi" -> + (* Mark stack as non-executable *) + ` .section .note.GNU-stack,\"\",%progbits\n` + | _ -> () + end diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 06b085b4..aed2b01a 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -1,12 +1,13 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* 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. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -26,32 +27,56 @@ let word_addressed = false (* Registers available for register allocation *) -(* Register map: - r0 - r3 general purpose (not preserved by C) - r4 - r7 general purpose (preserved) - r8 allocation pointer (preserved) - r9 platform register, usually reserved - r10 allocation limit (preserved) - r11 trap pointer (preserved) - r12 general purpose (not preserved by C) - r13 stack pointer - r14 return address - r15 program counter +(* Integer register map: + r0 - r3 general purpose (not preserved) + r4 - r7 general purpose (preserved) + r8 trap pointer (preserved) + r9 platform register, usually reserved + r10 allocation pointer (preserved) + r11 allocation limit (preserved) + r12 intra-procedural scratch register (not preserved) + r13 stack pointer + r14 return address + r15 program counter + Floatinng-point register map (VFPv3): + d0 - d7 general purpose (not preserved) + d8 - d15 general purpose (preserved) + d16 - d31 generat purpose (not preserved), VFPv3 only *) -let int_reg_name = [| - "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" -|] +let int_reg_name = + [| "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" |] + +let float_reg_name = + [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; + "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; + "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; + "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] + +(* We have three register classes: + 0 for integer registers + 1 for VFPv3-D16 + 2 for VFPv3 + This way we can choose between VFPv3-D16 and VFPv3 + at (ocamlopt) runtime using command line switches. +*) -let num_register_classes = 1 +let num_register_classes = 3 -let register_class r = assert (r.typ <> Float); 0 +let register_class r = + match (r.typ, !fpu) with + (Int | Addr), _ -> 0 + | Float, VFPv3_D16 -> 1 + | Float, _ -> 2 -let num_available_registers = [| 9 |] +let num_available_registers = + [| 9; 16; 32 |] -let first_available_register = [| 0 |] +let first_available_register = + [| 0; 100; 100 |] -let register_name r = int_reg_name.(r) +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) let rotate_registers = true @@ -59,25 +84,34 @@ let rotate_registers = true let hard_int_reg = let v = Array.create 9 Reg.dummy in - for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; + for i = 0 to 8 do + v.(i) <- Reg.at_location Int (Reg i) + done; + v + +let hard_float_reg = + let v = Array.create 32 Reg.dummy in + for i = 0 to 31 do + v.(i) <- Reg.at_location Float (Reg(100 + i)) + done; v -let all_phys_regs = hard_int_reg +let all_phys_regs = + Array.append hard_int_reg hard_float_reg -let phys_reg n = all_phys_regs.(n) +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let stack_slot slot ty = - assert (ty <> Float); Reg.at_location ty (Stack slot) (* Calling conventions *) -(* XXX float types have already been expanded into pairs of integers. - So we cannot align these floats. See if that causes a problem. *) - -let calling_conventions first_int last_int make_stack arg = +let calling_conventions + first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in + let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with @@ -90,37 +124,86 @@ let calling_conventions first_int last_int make_stack arg = ofs := !ofs + size_int end | Float -> - assert false + assert (abi = EABI_VFP); + assert (!fpu >= VFPv3_D16); + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + ofs := Misc.align !ofs size_float; + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end done; - (loc, Misc.align !ofs 8) + (loc, Misc.align !ofs 8) (* keep stack 8-aligned *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +(* OCaml calling convention: + first integer args in r0...r7 + first float args in d0...d15 (EABI+VFP) + remaining args on stack. + Return values in r0...r7 or d0...d15. *) + let loc_arguments arg = - calling_conventions 0 7 outgoing arg + calling_conventions 0 7 100 115 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 7 incoming arg in loc + let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 7 not_supported res in loc + let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc + +(* C calling convention: + first integer args in r0...r3 + first float args in d0...d7 (EABI+VFP) + remaining args on stack. + Return values in r0...r1 or d0. *) let loc_external_arguments arg = - calling_conventions 0 3 outgoing arg + calling_conventions 0 3 100 107 outgoing arg let loc_external_results res = - let (loc, ofs) = calling_conventions 0 1 not_supported res in loc + let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* Registers destroyed by operations *) -let destroyed_at_c_call = (* r4-r7 preserved *) - Array.of_list(List.map phys_reg [0;1;2;3;8]) +let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) + Array.of_list (List.map + phys_reg + [7;8; + 116;116;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131]) + +let destroyed_at_c_call = + Array.of_list (List.map + phys_reg + (match abi with + EABI -> (* r4-r7 preserved *) + [0;1;2;3;8; + 100;101;102;103;104;105;106;107; + 108;109;110;111;112;113;114;115; + 116;116;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131] + | EABI_VFP -> (* 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 _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Ialloc(_)) -> [|phys_reg 8|] (* r12 destroyed *) + Iop(Icall_ind | Icall_imm _ ) + | Iop(Iextcall(_, true)) -> + all_phys_regs + | Iop(Iextcall(_, false)) -> + destroyed_at_c_call + | Iop(Ialloc n) -> + destroyed_at_alloc + | Iop(Iconst_symbol _) when !pic_code -> + [|phys_reg 3; phys_reg 8|] (* r3 and r12 destroyed *) + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + [|phys_reg 107|] (* d7 (s14-s15) destroyed *) | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -128,15 +211,16 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 4 + Iextcall(_, _) -> 5 | _ -> 9 + let max_register_pressure = function - Iextcall(_, _) -> [| 4 |] - | _ -> [| 9 |] + Iextcall(_, _) -> [| 5; 9; 9 |] + | _ -> [| 9; 16; 32 |] (* Layout of the stack *) -let num_stack_slots = [| 0 |] +let num_stack_slots = [| 0; 0; 0 |] let contains_calls = ref false (* Calling the assembler *) @@ -144,6 +228,3 @@ let contains_calls = ref false let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml index 65d81181..c5b137ab 100644 --- a/asmcomp/arm/reload.ml +++ b/asmcomp/arm/reload.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index 8f49ad1e..4b47733f 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -1,51 +1,79 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* 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. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) +open Arch open Mach -(* Instruction scheduling for the Sparc *) +(* Instruction scheduling for the ARM *) -class scheduler = object +class scheduler = object(self) -inherit Schedgen.scheduler_generic +inherit Schedgen.scheduler_generic as super -(* Scheduling -- based roughly on the Strong ARM *) +(* Scheduling -- based roughly on the ARM11 (ARMv6) *) method oper_latency = function - Ireload -> 2 - | Iload(_, _) -> 2 - | Iconst_symbol _ -> 2 (* turned into a load *) - | Iconst_float _ -> 2 (* turned into a load *) - | Iintop(Imul) -> 3 - | Iintop_imm(Imul, _) -> 3 - (* No data available for floatops, let's make educated guesses *) - | Iaddf -> 3 - | Isubf -> 3 - | Imulf -> 5 - | Idivf -> 15 + (* Loads have a latency of two cycles in general *) + Iconst_symbol _ + | Iconst_float _ + | Iload(_, _) + | Ireload + | Ifloatofint (* mcr/mrc count as memory access *) + | Iintoffloat -> 2 + (* Multiplys have a latency of two cycles *) + | Iintop Imul + | Ispecific(Imuladd | Imulsub) -> 2 + (* VFP instructions *) + | Iaddf + | Isubf + | Idivf + | Imulf | Ispecific Inegmulf + | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) + | Ispecific Isqrtf + | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2 + (* Everything else *) | _ -> 1 -(* Issue cycles. Rough approximations *) +method! is_checkbound = function + Ispecific(Ishiftcheckbound _) -> true + | op -> super#is_checkbound op + +(* Issue cycles. Rough approximations *) method oper_issue_cycles = function Ialloc _ -> 4 - | Iintop(Icomp _) -> 3 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 6 + | Iintop(Ilsl | Ilsr | Iasr) -> 2 + | Iintop(Icomp _) | Iintop_imm(Icomp _, _) -> 3 + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> 2 + | Ispecific(Ishiftcheckbound _) -> 3 + | Iintop_imm(Idiv, _) -> 4 + | Iintop_imm(Imod, _) -> 6 + | Iintop Imul + | Ispecific(Imuladd | Imulsub) -> 2 + (* VFP instructions *) + | Iaddf + | Isubf -> 7 + | Imulf + | Ispecific Inegmulf -> 9 + | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17 + | Idivf + | Ispecific Isqrtf -> 27 + | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4 + (* Everything else *) | _ -> 1 end diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 1574bf01..94d0367b 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -1,12 +1,13 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* 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. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -14,41 +15,63 @@ (* Instruction selection for the ARM processor *) -open Misc -open Cmm -open Reg open Arch -open Proc +open Cmm open Mach +open Misc +open Proc +open Reg -(* Immediate operands are 8-bit immediate values, zero-extended, and rotated - right by 0, 2, 4, ... 30 bits. - To avoid problems with Caml's 31-bit arithmetic, - we check only with 8-bit values shifted left 0 to 22 bits. *) - -let rec is_immed n shift = - if shift > 22 then false - else if n land (0xFF lsl shift) = n then true - else is_immed n (shift + 2) +let is_offset chunk n = + match chunk with + (* VFPv3 load/store have -1020 to 1020 *) + Single | Double | Double_u + when !fpu >= VFPv3_D16 -> + n >= -1020 && n <= 1020 + (* ARM load/store byte/word have -4095 to 4095 *) + | Byte_unsigned | Byte_signed + | Thirtytwo_unsigned | Thirtytwo_signed + | Word | Single + when not !thumb -> + n >= -4095 && n <= 4095 + (* Thumb-2 load/store have -255 to 4095 *) + | _ when !arch > ARMv6 && !thumb -> + n >= -255 && n <= 4095 + (* Everything else has -255 to 255 *) + | _ -> + n >= -255 && n <= 255 -(* We have 12-bit + sign byte offsets for word accesses, - 8-bit + sign word offsets for float accesses, - and 8-bit + sign byte offsets for bytes and shorts. - Use lowest common denominator. *) +let is_intconst = function + Cconst_int _ -> true + | _ -> false -let is_offset n = n < 256 && n > -256 +(* Special constraints on operand and result registers *) -let is_intconst = function Cconst_int n -> true | _ -> false +exception Use_default -(* Soft emulation of float comparisons *) +let r1 = phys_reg 1 -let float_comparison_function = function - | Ceq -> "__eqdf2" - | Cne -> "__nedf2" - | Clt -> "__ltdf2" - | Cle -> "__ledf2" - | Cgt -> "__gtdf2" - | Cge -> "__gedf2" +let pseudoregs_for_operation op arg res = + match op with + (* For mul rd,rm,rs and mla rd,rm,rs,ra (pre-ARMv6) the registers rm + and rd must be different. We deal with this by pretending that rm + is also a result of the mul / mla operation. *) + Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> + (arg, [| res.(0); arg.(0) |]) + (* 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 *) + | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> + let arg' = Array.copy arg in + arg'.(0) <- res.(0); + (arg', res) + (* We use __aeabi_idivmod for Cmodi only, and hence we care only + for the remainder in r1, so fix up the destination register. *) + | Iextcall("__aeabi_idivmod", false) -> + (arg, [|r1|]) + (* Other instructions are regular *) + | _ -> raise Use_default (* Instruction selection *) class selector = object(self) @@ -56,23 +79,32 @@ class selector = object(self) inherit Selectgen.selector_generic as super method! regs_for tyv = - (* Expand floats into pairs of integer registers *) - let nty = Array.length tyv in - let rec expand i = - if i >= nty then [] else begin - match tyv.(i) with - | Float -> Int :: Int :: expand (i+1) - | ty -> ty :: expand (i+1) - end in - Reg.createv (Array.of_list (expand 0)) + Reg.createv (if !fpu = Soft then begin + (* Expand floats into pairs of integer registers *) + let rec expand = function + [] -> [] + | Float :: tyl -> Int :: Int :: expand tyl + | ty :: tyl -> ty :: expand tyl in + Array.of_list (expand (Array.to_list tyv)) + end else begin + tyv + end) method is_immediate n = - n land 0xFF = n || is_immed n 2 + is_immediate (Int32.of_int n) + +method! is_simple_expr = function + (* inlined floating-point ops are simple if their arguments are *) + | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 -> + List.for_all self#is_simple_expr args + | e -> super#is_simple_expr e -method select_addressing = function - Cop(Cadda, [arg; Cconst_int n]) when is_offset n -> +method select_addressing chunk = function + | Cop(Cadda, [arg; Cconst_int n]) + when is_offset chunk n -> (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when is_offset n -> + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) + when is_offset chunk n -> (Iindexed n, Cop(Cadda, [arg1; arg2])) | arg -> (Iindexed 0, arg) @@ -91,109 +123,146 @@ method select_shift_arith op shiftop shiftrevop args = | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg1) -> (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) - | _ -> - super#select_operation op args + | args -> + begin match super#select_operation op args with + (* Recognize multiply and add *) + (Iintop Iadd, [Cop(Cmuli, args); arg3]) + | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args -> + begin match self#select_operation Cmuli args with + (Iintop Imul, [arg1; arg2]) -> + (Ispecific Imuladd, [arg1; arg2; arg3]) + | _ -> op_args + end + (* Recognize multiply and subtract *) + | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args + when !arch > ARMv6 -> + begin match self#select_operation Cmuli args with + (Iintop Imul, [arg1; arg2]) -> + (Ispecific Imulsub, [arg1; arg2; arg3]) + | _ -> op_args + end + | op_args -> op_args + end method! select_operation op args = - match op with - Cadda | Caddi -> - begin match args with - [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) -> - (Iintop_imm(Isub, -n), [arg1]) - | _ -> - self#select_shift_arith op Ishiftadd Ishiftadd args - end - | Csuba | Csubi -> - begin match args with - [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) -> - (Iintop_imm(Iadd, -n), [arg1]) - | [Cconst_int n; arg2] when self#is_immediate n -> - (Ispecific(Irevsubimm n), [arg2]) - | _ -> - self#select_shift_arith op Ishiftsub Ishiftsubrev args - end - | Cmuli -> (* no multiply immediate *) + match (op, args) with + (* Recognize special shift arithmetic *) + ((Cadda | Caddi), [arg; Cconst_int n]) + when n < 0 && self#is_immediate (-n) -> + (Iintop_imm(Isub, -n), [arg]) + | ((Cadda | Caddi as op), args) -> + self#select_shift_arith op Ishiftadd Ishiftadd args + | ((Csuba | Csubi), [arg; Cconst_int n]) + when n < 0 && self#is_immediate (-n) -> + (Iintop_imm(Iadd, -n), [arg]) + | ((Csuba | Csubi), [Cconst_int n; arg]) + when self#is_immediate n -> + (Ispecific(Irevsubimm n), [arg]) + | ((Csuba | Csubi as op), args) -> + self#select_shift_arith op Ishiftsub Ishiftsubrev args + | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2]) + when n > 0 && n < 32 && not(is_intconst arg2) -> + (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + (* ARM does not support immediate operands for multiplication *) + | (Cmuli, args) -> (Iintop Imul, args) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> - (Iextcall("__divsi3", false), args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> - (Iextcall("__modsi3", false), args) - end - | Ccheckbound _ -> - begin match args with - [Cop(Clsr, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) - | _ -> - super#select_operation op args - end - (* Turn floating-point operations into library function calls *) - | Caddf -> (Iextcall("__adddf3", false), args) - | Csubf -> (Iextcall("__subdf3", false), args) - | Cmulf -> (Iextcall("__muldf3", false), args) - | Cdivf -> (Iextcall("__divdf3", false), args) - | Cfloatofint -> (Iextcall("__floatsidf", false), args) - | Cintoffloat -> (Iextcall("__fixdfsi", false), args) - | Ccmpf comp -> - (Iintop_imm(Icomp(Isigned comp), 0), - [Cop(Cextcall(float_comparison_function comp, - typ_int, false, Debuginfo.none), - args)]) + (* Turn integer division/modulus into runtime ABI calls *) + | (Cdivi, [arg; Cconst_int n]) + when n = 1 lsl Misc.log2 n -> + (Iintop_imm(Idiv, n), [arg]) + | (Cdivi, args) -> + (Iextcall("__aeabi_idiv", false), args) + | (Cmodi, [arg; Cconst_int n]) + when 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) + (* 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 *) + | (op, args) -> self#select_operation_vfpv3 op args + +method private select_operation_softfp op args = + match (op, args) with + (* Turn floating-point operations into runtime ABI calls *) + | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args) + | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args) + | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args) + | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args) + | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args) + | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args) + | (Ccmpf comp, args) -> + let func = (match comp with + Cne (* there's no __aeabi_dcmpne *) + | Ceq -> "__aeabi_dcmpeq" + | Clt -> "__aeabi_dcmplt" + | Cle -> "__aeabi_dcmple" + | Cgt -> "__aeabi_dcmpgt" + | Cge -> "__aeabi_dcmpge") in + let comp = (match comp with + Cne -> Ceq (* eq 0 => false *) + | _ -> Cne (* ne 0 => true *)) in + (Iintop_imm(Icomp(Iunsigned comp), 0), + [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)]) (* Add coercions around loads and stores of 32-bit floats *) - | Cload Single -> - (Iextcall("__extendsfdf2", false), [Cop(Cload Word, args)]) - | Cstore Single -> - begin match args with - | [arg1; arg2] -> - let arg2' = - Cop(Cextcall("__truncdfsf2", typ_int, false, Debuginfo.none), - [arg2]) in - self#select_operation (Cstore Word) [arg1; arg2'] - | _ -> assert false - end + | (Cload Single, args) -> + (Iextcall("__aeabi_f2d", false), [Cop(Cload Word, args)]) + | (Cstore Single, [arg1; arg2]) -> + let arg2' = + Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none), + [arg2]) in + self#select_operation (Cstore Word) [arg1; arg2'] (* Other operations are regular *) - | _ -> super#select_operation op args + | (op, args) -> super#select_operation op args + +method private select_operation_vfpv3 op args = + match (op, args) with + (* Recognize floating-point negate and multiply *) + (Cnegf, [Cop(Cmulf, args)]) -> + (Ispecific Inegmulf, args) + (* Recognize floating-point multiply and add *) + | (Caddf, [arg; Cop(Cmulf, args)]) + | (Caddf, [Cop(Cmulf, args); arg]) -> + (Ispecific Imuladdf, arg :: args) + (* Recognize floating-point negate, multiply and subtract *) + | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)]) + | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) -> + (Ispecific Inegmulsubf, arg :: args) + (* Recognize floating-point negate, multiply and add *) + | (Csubf, [arg; Cop(Cmulf, args)]) -> + (Ispecific Inegmuladdf, arg :: args) + (* Recognize multiply and subtract *) + | (Csubf, [Cop(Cmulf, args); arg]) -> + (Ispecific Imulsubf, arg :: args) + (* Recognize floating-point square root *) + | (Cextcall("sqrt", _, false, _), args) -> + (Ispecific Isqrtf, args) + (* Other operations are regular *) + | (op, args) -> super#select_operation op args method! select_condition = function - | Cop(Ccmpf cmp, args) -> - (Iinttest_imm(Isigned cmp, 0), - Cop(Cextcall(float_comparison_function cmp, - typ_int, false, Debuginfo.none), - args)) + (* Turn floating-point comparisons into runtime ABI calls *) + Cop(Ccmpf _ as op, args) when !fpu = Soft -> + begin match self#select_operation_softfp op args with + (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg) + | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg) + | _ -> assert false + end | expr -> super#select_condition expr -(* Deal with some register irregularities: - -1- In mul rd, rm, rs, the registers rm and rd must be different. - We deal with this by pretending that rm is also a result of the mul - operation. - -2- For Inegf and Iabsf, force arguments and results in (r0, r1); - this simplifies code generation later. -*) +(* Deal with some register constraints *) method! insert_op_debug op dbg rs rd = - match op with - | Iintop(Imul) -> - self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd - | Iabsf | Inegf -> - let r = [| phys_reg 0; phys_reg 1 |] in - self#insert_moves rs r; - self#insert_debug (Iop op) dbg r r; - self#insert_moves r rd; - rd - | _ -> - super#insert_op_debug op dbg rs rd + try + let (rsrc, rdst) = pseudoregs_for_operation op rs rd in + self#insert_moves rs rsrc; + self#insert_debug (Iop op) dbg rsrc rdst; + self#insert_moves rdst rd; + rd + with Use_default -> + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 9cdf61f4..5f513db1 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -135,4 +135,5 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) = let report_error ppf = function | Assembler_error file -> - fprintf ppf "Assembler error, input left in file %s" file + fprintf ppf "Assembler error, input left in file %a" + Location.print_filename file diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index fe578bd4..f71cba8f 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index 1fddb812..e0d2170b 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli index 66f6a127..20a0380c 100644 --- a/asmcomp/asmlibrarian.mli +++ b/asmcomp/asmlibrarian.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index e8930139..e99e62a3 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -101,7 +101,7 @@ let runtime_lib () = let libname = if !Clflags.gprofile then "libasmrunp" ^ ext_lib - else "libasmrun" ^ ext_lib in + else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in try if !Clflags.nopervasives then [] else [ find_in_path !load_path libname ] @@ -342,7 +342,8 @@ let report_error ppf = function | File_not_found name -> fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> - fprintf ppf "The file %s is not a compilation unit description" name + fprintf ppf "The file %a is not a compilation unit description" + Location.print_filename name | Missing_implementations l -> let print_references ppf = function | [] -> () @@ -359,27 +360,35 @@ let report_error ppf = function print_modules l | Inconsistent_interface(intf, file1, file2) -> fprintf ppf - "@[Files %s@ and %s@ make inconsistent assumptions \ + "@[Files %a@ and %a@ make inconsistent assumptions \ over interface %s@]" - file1 file2 intf + Location.print_filename file1 + Location.print_filename file2 + intf | Inconsistent_implementation(intf, file1, file2) -> fprintf ppf - "@[Files %s@ and %s@ make inconsistent assumptions \ + "@[Files %a@ and %a@ make inconsistent assumptions \ over implementation %s@]" - file1 file2 intf + Location.print_filename file1 + Location.print_filename file2 + intf | Assembler_error file -> - fprintf ppf "Error while assembling %s" file + fprintf ppf "Error while assembling %a" Location.print_filename file | Linking_error -> fprintf ppf "Error during linking" | Multiple_definition(modname, file1, file2) -> fprintf ppf - "@[Files %s@ and %s@ both define a module named %s@]" - file1 file2 modname + "@[Files %a@ and %a@ both define a module named %s@]" + Location.print_filename file1 + Location.print_filename file2 + modname | Missing_cmx(filename, name) -> fprintf ppf - "@[File %s@ was compiled without access@ \ + "@[File %a@ was compiled without access@ \ to the .cmx file@ for module %s,@ \ which was produced by `ocamlopt -for-pack'.@ \ - Please recompile %s@ with the correct `-I' option@ \ + Please recompile %a@ with the correct `-I' option@ \ so that %s.cmx@ is found.@]" - filename name filename name + Location.print_filename filename name + Location.print_filename filename + name diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index dbebb7be..b9465f80 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index fadfa49f..3f44a0a9 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -193,13 +193,14 @@ open Format let report_error ppf = function Illegal_renaming(file, id) -> - fprintf ppf "Wrong file naming: %s@ contains the code for@ %s" - file id + fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" + Location.print_filename file id | Forward_reference(file, ident) -> - fprintf ppf "Forward reference to %s in file %s" ident file + fprintf ppf "Forward reference to %s in file %a" ident + Location.print_filename file | Wrong_for_pack(file, path) -> - fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option" - file path + fprintf ppf "File %a@ was not compiled with the `-for-pack %s' option" + Location.print_filename file path | File_not_found file -> fprintf ppf "File %s not found" file | Assembler_error file -> diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli index 7d0bb588..fafccfea 100644 --- a/asmcomp/asmpackager.mli +++ b/asmcomp/asmpackager.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 5e31c3bb..9a01de81 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -22,11 +22,10 @@ type function_label = string type ulambda = Uvar of Ident.t - | Uconst of structured_constant + | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list - * ulambda list + | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda @@ -42,6 +41,14 @@ type ulambda = | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t +and ufunction = { + label : function_label; + arity : int; + params : Ident.t list; + body : ulambda; + dbg : Debuginfo.t +} + and ulambda_switch = { us_index_consts: int array; us_actions_consts : ulambda array; diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 724490c5..808c1c6d 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -22,11 +22,10 @@ type function_label = string type ulambda = Uvar of Ident.t - | Uconst of structured_constant + | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list - * ulambda list + | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda @@ -42,6 +41,14 @@ type ulambda = | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t +and ufunction = { + label : function_label; + arity : int; + params : Ident.t list; + body : ulambda; + dbg : Debuginfo.t; +} + and ulambda_switch = { us_index_consts: int array; us_actions_consts: ulambda array; diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 4ff4d720..03ed0c12 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -50,7 +50,7 @@ let getglobal id = let occurs_var var u = let rec occurs = function Uvar v -> v = var - | Uconst cst -> false + | Uconst (cst,_) -> false | Udirect_apply(lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos @@ -120,9 +120,12 @@ let lambda_smaller lam threshold = if !size > threshold then raise Exit; match lam with Uvar v -> () - | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | + | Uconst( + (Const_base(Const_int _ | Const_char _ | Const_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _) | - Const_pointer _) -> incr size + Const_pointer _), _) -> incr size +(* Structured Constants are now emitted during closure conversion. *) + | Uconst (_, Some _) -> incr size | Uconst _ -> raise Exit (* avoid duplication of structured constants *) | Udirect_apply(fn, args, _) -> @@ -177,7 +180,7 @@ let lambda_smaller lam threshold = let rec is_pure_clambda = function Uvar v -> true - | Uconst cst -> true + | Uconst _ -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false @@ -186,8 +189,8 @@ let rec is_pure_clambda = function (* Simplify primitive operations on integers *) -let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n) -let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n) +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 simplif_prim_pure p (args, approxs) dbg = @@ -254,16 +257,16 @@ let simplif_prim p (args, approxs as args_approxs) dbg = over functions. *) let approx_ulam = function - Uconst(Const_base(Const_int n)) -> Value_integer n - | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c) - | Uconst(Const_pointer n) -> Value_constptr n + Uconst(Const_base(Const_int n),_) -> Value_integer n + | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c) + | Uconst(Const_pointer n,_) -> Value_constptr n | _ -> Value_unknown let rec substitute sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end - | Uconst cst -> ulam + | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> Udirect_apply(lbl, List.map (substitute sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> @@ -313,7 +316,7 @@ let rec substitute sb ulam = Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> begin match substitute sb u1 with - Uconst(Const_pointer n) -> + Uconst(Const_pointer n, _) -> if n <> 0 then substitute sb u2 else substitute sb u3 | su1 -> Uifthenelse(su1, substitute sb u2, substitute sb u3) @@ -339,14 +342,14 @@ let rec substitute sb ulam = let is_simple_argument = function Uvar _ -> true | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _)) -> + Const_int32 _ | Const_int64 _ | Const_nativeint _),_) -> true - | Uconst(Const_pointer _) -> true + | Uconst(Const_pointer _, _) -> true | _ -> false let no_effects = function Uclosure _ -> true - | Uconst(Const_base(Const_string _)) -> true + | Uconst(Const_base(Const_string _),_) -> true | u -> is_simple_argument u let rec bind_params_rec subst params args body = @@ -485,13 +488,16 @@ let rec close fenv cenv = function close_approx_var fenv cenv id | Lconst cst -> begin match cst with - Const_base(Const_int n) -> (Uconst cst, Value_integer n) - | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c)) - | Const_pointer n -> (Uconst cst, Value_constptr n) - | _ -> (Uconst cst, Value_unknown) + 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_pointer n -> (Uconst (cst, None), Value_constptr n) + | _ -> (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 + + (* We convert [f a] to [let a' = a in fun b c -> f a' b c] + when fun_arity > nargs *) | Lapply(funct, args, loc) -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with @@ -504,6 +510,31 @@ let rec close fenv cenv = function when nargs = fundesc.fun_arity -> let app = direct_apply fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) + + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + 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 rec iter args body = + match args with + [] -> body + | (arg1, arg2) :: args -> + iter args + (Ulet ( arg1, arg2, body)) + in + let internal_args = + (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) + @ (List.map (fun arg -> Lvar arg ) final_args) + in + let (new_fun, approx) = close fenv cenv + (Lfunction( + Curried, final_args, Lapply(funct, internal_args, loc))) + in + let new_fun = iter first_args new_fun in + (new_fun, approx) + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in @@ -563,6 +594,9 @@ let rec close fenv cenv = function let (ubody, approx) = close fenv_body cenv body in (Uletrec(udefs, ubody), approx) end + | Lprim(Pdirapply loc,[funct;arg]) + | Lprim(Prevapply loc,[arg;funct]) -> + close fenv cenv (Lapply(funct, [arg], loc)) | Lprim(Pgetglobal id, []) as lam -> check_constant_result lam (getglobal id) @@ -714,6 +748,9 @@ and close_functions fenv cenv fun_defs = let useless_env = ref initially_closed in (* Translate each function definition *) let clos_fundef (id, params, body, fundesc) env_pos = + let dbg = match body with + | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev + | _ -> Debuginfo.none in let env_param = Ident.create "env" in let cenv_fv = build_closure_env env_param (fv_pos - env_pos) fv in @@ -725,7 +762,11 @@ and close_functions fenv cenv fun_defs = let (ubody, approx) = close fenv_rec cenv_body body in if !useless_env && occurs_var env_param ubody then useless_env := false; let fun_params = if !useless_env then params else params @ [env_param] in - ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody), + ({ label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = fun_params; + body = ubody; + dbg }, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = @@ -755,11 +796,12 @@ and close_functions fenv cenv fun_defs = and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([_, _, params, body], _) as clos), + ((Uclosure([f], _) as clos), [_, _, (Value_closure(fundesc, _) as approx)]) -> (* See if the function can be inlined *) - if lambda_smaller body (!Clflags.inline_threshold + List.length params) - then fundesc.fun_inline <- Some(params, body); + if lambda_smaller f.body + (!Clflags.inline_threshold + List.length f.params) + then fundesc.fun_inline <- Some(f.params, f.body); (clos, approx) | _ -> fatal_error "Closure.close_one_function" diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli index f1637906..f406603c 100644 --- a/asmcomp/closure.mli +++ b/asmcomp/closure.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 68625e24..7787a220 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -108,7 +108,8 @@ type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t; } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 1b090716..5787bcb9 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -94,7 +94,8 @@ type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t; } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index ca9d2f04..0b5d09db 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -159,13 +159,16 @@ let ignore_low_bit_int = function | Cop(Cor, [c; Cconst_int 1]) -> c | c -> c -let is_nonzero_constant = function - Cconst_int n -> n <> 0 - | Cconst_natint n -> n <> 0n +(* Division or modulo on tagged integers. The overflow case min_int / -1 + cannot occur, but we must guard against division by zero. *) + +let is_different_from x = function + Cconst_int n -> n <> x + | Cconst_natint n -> n <> Nativeint.of_int x | _ -> false let safe_divmod op c1 c2 dbg = - if !Clflags.fast || is_nonzero_constant c2 then + if !Clflags.fast || is_different_from 0 c2 then Cop(op, [c1; c2]) else bind "divisor" c2 (fun c2 -> @@ -174,6 +177,35 @@ let safe_divmod op c1 c2 dbg = Cop(Craise dbg, [Cconst_symbol "caml_bucket_Division_by_zero"]))) +(* Division or modulo on boxed integers. The overflow case min_int / -1 + can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) + +let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = + bind "dividend" c1 (fun c1 -> + bind "divisor" c2 (fun c2 -> + let c3 = + if Arch.division_crashes_on_overflow + && (size_int = 4 || bi <> Pint32) + && not (is_different_from (-1) c2) + then + Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1) + else + mkop c1 c2 in + if !Clflags.fast || is_different_from 0 c2 then + c3 + else + Cifthenelse(c2, c3, + Cop(Craise dbg, + [Cconst_symbol "caml_bucket_Division_by_zero"])))) + +let safe_div_bi = + safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2])) + (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) + +let safe_mod_bi = + safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2])) + (fun c1 -> Cconst_int 0) + (* Bool *) let test_bool = function @@ -369,18 +401,26 @@ let make_float_alloc tag args = make_alloc_generic float_array_set tag (List.length args * size_float / size_addr) args +(* Bounds checking *) + +let make_checkbound dbg = function + | [Cop(Clsr, [a1; Cconst_int n]); Cconst_int m] when (m lsl n) > n -> + Cop(Ccheckbound dbg, [a1; Cconst_int(m lsl n + 1 lsl n - 1)]) + | args -> + Cop(Ccheckbound dbg, args) + (* To compile "let rec" over values *) let fundecls_size fundecls = let sz = ref (-1) in List.iter - (fun (label, arity, params, body) -> - sz := !sz + 1 + (if arity = 1 then 2 else 3)) + (fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3)) fundecls; !sz type rhs_kind = | RHS_block of int + | RHS_floatblock of int | RHS_nonrec ;; let rec expr_size = function @@ -394,6 +434,8 @@ let rec expr_size = function RHS_block (List.length args) | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> RHS_block (List.length args) + | Uprim(Pmakearray(Pfloatarray), args, _) -> + RHS_floatblock (List.length args) | Usequence(exp, exp') -> expr_size exp' | _ -> RHS_nonrec @@ -420,6 +462,7 @@ let transl_comparison = function (* Translate structured constants *) +(* Fabrice: moved to compilenv.ml ---- let const_label = ref 0 let new_const_label () = @@ -431,6 +474,7 @@ let new_const_symbol () = Compilenv.make_symbol (Some (string_of_int !const_label)) let structured_constants = ref ([] : (string * structured_constant) list) +*) let transl_constant = function Const_base(Const_int n) -> @@ -443,14 +487,12 @@ let transl_constant = function else Cconst_natpointer (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) | cst -> - let lbl = new_const_symbol() in - structured_constants := (lbl, cst) :: !structured_constants; - Cconst_symbol lbl + Cconst_symbol (Compilenv.new_structured_constant cst false) (* Translate constant closures *) let constant_closures = - ref ([] : (string * (string * int * Ident.t list * ulambda) list) list) + ref ([] : (string * ufunction list) list) (* Boxed integers *) @@ -534,7 +576,7 @@ let bigarray_elt_size = function let bigarray_indexing unsafe elt_kind layout b args dbg = let check_bound a1 a2 k = - if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in + if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) in let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> @@ -726,7 +768,7 @@ type unboxed_number_kind = | Boxed_integer of boxed_integer let is_unboxed_number = function - Uconst(Const_base(Const_float f)) -> + Uconst(Const_base(Const_float f), _) -> Boxed_float | Uprim(p, _, _) -> begin match simplif_primitive p with @@ -797,20 +839,19 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp = (* Translate an expression *) -let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t) +let functions = (Queue.create() : ufunction Queue.t) let rec transl = function Uvar id -> Cvar id - | Uconst sc -> + | Uconst (sc, Some const_label) -> + Cconst_symbol const_label + | Uconst (sc, None) -> transl_constant sc | Uclosure(fundecls, []) -> - let lbl = new_const_symbol() in + let lbl = Compilenv.new_const_symbol() in constant_closures := (lbl, fundecls) :: !constant_closures; - List.iter - (fun (label, arity, params, body) -> - Queue.add (label, params, body) functions) - fundecls; + List.iter (fun f -> Queue.add f functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> let block_size = @@ -818,22 +859,22 @@ let rec transl = function let rec transl_fundecls pos = function [] -> List.map transl clos_vars - | (label, arity, params, body) :: rem -> - Queue.add (label, params, body) functions; + | f :: rem -> + Queue.add f functions; let header = if pos = 0 then alloc_closure_header block_size else alloc_infix_header pos in - if arity = 1 then + if f.arity = 1 then header :: - Cconst_symbol label :: + Cconst_symbol f.label :: int_const 1 :: transl_fundecls (pos + 3) rem else header :: - Cconst_symbol(curry_function arity) :: - int_const arity :: - Cconst_symbol label :: + Cconst_symbol(curry_function f.arity) :: + int_const f.arity :: + Cconst_symbol f.label :: transl_fundecls (pos + 4) rem in Cop(Calloc, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> @@ -1070,7 +1111,7 @@ and transl_prim_1 p arg dbg = 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))) 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 -> @@ -1207,7 +1248,7 @@ and transl_prim_2 p arg1 arg2 dbg = (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( - Cop(Ccheckbound dbg, [string_length str; idx]), + make_checkbound dbg [string_length str; idx], Cop(Cload Byte_unsigned, [add_int str idx]))))) (* Array operations *) @@ -1226,26 +1267,31 @@ and transl_prim_2 p arg1 arg2 dbg = end | Parrayrefs kind -> begin match kind with - Pgenarray -> + | Pgenarray -> bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - bind "header" (header arr) (fun hdr -> - Cifthenelse(is_addr_array_hdr hdr, - Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]), - addr_array_ref arr idx), - Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]), - float_array_ref arr idx))))) + bind "arr" (transl arg1) (fun arr -> + bind "header" (header arr) (fun hdr -> + if wordsize_shift = numfloat_shift then + Csequence(make_checkbound dbg [addr_array_length hdr; idx], + Cifthenelse(is_addr_array_hdr hdr, + addr_array_ref arr idx, + float_array_ref arr idx)) + else + Cifthenelse(is_addr_array_hdr hdr, + Csequence(make_checkbound dbg [addr_array_length hdr; idx], + addr_array_ref arr idx), + Csequence(make_checkbound dbg [float_array_length hdr; idx], + float_array_ref arr idx))))) | Paddrarray | Pintarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), + 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(Cop(Ccheckbound dbg, - [float_array_length(header arr); idx]), + Csequence(make_checkbound dbg [float_array_length(header arr); idx], unboxed_float_array_ref arr idx)))) end @@ -1270,13 +1316,13 @@ and transl_prim_2 p arg1 arg2 dbg = box_int bi (Cop(Cmuli, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pdivbint bi -> - box_int bi (safe_divmod Cdivi + box_int bi (safe_div_bi (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) - dbg) + bi dbg) | Pmodbint bi -> - box_int bi (safe_divmod Cmodi + box_int bi (safe_mod_bi (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) - dbg) + bi dbg) | Pandbint bi -> box_int bi (Cop(Cand, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) @@ -1314,7 +1360,7 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( - Cop(Ccheckbound dbg, [string_length str; idx]), + make_checkbound dbg [string_length str; idx], Cop(Cstore Byte_unsigned, [add_int str idx; untag_int(transl arg3)]))))) @@ -1337,48 +1383,58 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = end) | Parraysets kind -> return_unit(begin match kind with - Pgenarray -> + | Pgenarray -> bind "newval" (transl arg3) (fun newval -> - bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - bind "header" (header arr) (fun hdr -> - Cifthenelse(is_addr_array_hdr hdr, - Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]), - addr_array_set arr idx newval), - Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]), - float_array_set arr idx - (unbox_float newval))))))) + bind "index" (transl arg2) (fun idx -> + bind "arr" (transl arg1) (fun arr -> + bind "header" (header arr) (fun hdr -> + if wordsize_shift = numfloat_shift then + Csequence(make_checkbound dbg [addr_array_length hdr; idx], + Cifthenelse(is_addr_array_hdr hdr, + addr_array_set arr idx newval, + float_array_set arr idx + (unbox_float newval))) + else + Cifthenelse(is_addr_array_hdr hdr, + Csequence(make_checkbound dbg [addr_array_length hdr; idx], + addr_array_set arr idx newval), + Csequence(make_checkbound dbg [float_array_length hdr; idx], + float_array_set arr idx + (unbox_float newval))))))) | Paddrarray -> + bind "newval" (transl arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), - addr_array_set arr idx (transl arg3)))) + bind "arr" (transl arg1) (fun arr -> + Csequence(make_checkbound dbg [addr_array_length(header arr); idx], + addr_array_set arr idx newval)))) | Pintarray -> + bind "newval" (transl arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), - int_array_set arr idx (transl arg3)))) + bind "arr" (transl arg1) (fun arr -> + Csequence(make_checkbound dbg [addr_array_length(header arr); idx], + int_array_set arr idx newval)))) | Pfloatarray -> + bind "newval" (transl_unbox_float arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]), - float_array_set arr idx (transl_unbox_float arg3)))) + bind "arr" (transl arg1) (fun arr -> + Csequence(make_checkbound dbg [float_array_length(header arr);idx], + float_array_set arr idx newval)))) end) | _ -> fatal_error "Cmmgen.transl_prim_3" and transl_unbox_float = function - Uconst(Const_base(Const_float f)) -> Cconst_float f + Uconst(Const_base(Const_float f), _) -> Cconst_float f | exp -> unbox_float(transl exp) and transl_unbox_int bi = function - Uconst(Const_base(Const_int32 n)) -> + Uconst(Const_base(Const_int32 n), _) -> Cconst_natint (Nativeint.of_int32 n) - | Uconst(Const_base(Const_nativeint n)) -> + | Uconst(Const_base(Const_nativeint n), _) -> Cconst_natint n - | Uconst(Const_base(Const_int64 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) @@ -1411,8 +1467,8 @@ and make_catch2 mk_body handler = match handler with and exit_if_true cond nfail otherwise = match cond with - | Uconst (Const_pointer 0) -> otherwise - | Uconst (Const_pointer 1) -> Cexit (nfail,[]) + | Uconst (Const_pointer 0, _) -> otherwise + | Uconst (Const_pointer 1, _) -> Cexit (nfail,[]) | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) | Uprim(Psequand, _, _) -> @@ -1441,8 +1497,8 @@ and exit_if_true cond nfail otherwise = and exit_if_false cond otherwise nfail = match cond with - | Uconst (Const_pointer 0) -> Cexit (nfail,[]) - | Uconst (Const_pointer 1) -> otherwise + | Uconst (Const_pointer 0, _) -> Cexit (nfail,[]) + | Uconst (Const_pointer 1, _) -> otherwise | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail | Uprim(Psequor, _, _) -> @@ -1502,36 +1558,41 @@ and transl_switch arg index cases = match Array.length cases with and transl_letrec bindings cont = let bsz = List.map (fun (id, exp) -> (id, exp, expr_size 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 | [] -> fill_nonrec bsz | (id, exp, RHS_block sz) :: rem -> - Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none), - [int_const sz]), - init_blocks rem) + Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem) + | (id, exp, RHS_floatblock sz) :: rem -> + Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem) | (id, exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz - | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem + | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> Clet (id, transl exp, fill_nonrec rem) and fill_blocks = function | [] -> cont - | (id, exp, RHS_block _) :: rem -> - Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), - [Cvar id; transl exp]), - fill_blocks rem) + | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + let op = + Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), + [Cvar id; transl exp]) in + Csequence(op, fill_blocks rem) | (id, exp, RHS_nonrec) :: rem -> fill_blocks rem in init_blocks bsz (* Translate a function definition *) -let transl_function lbl params body = - Cfunction {fun_name = lbl; - fun_args = List.map (fun id -> (id, typ_addr)) params; - fun_body = transl body; - fun_fast = !Clflags.optimize_for_speed} +let transl_function f = + Cfunction {fun_name = f.label; + fun_args = List.map (fun id -> (id, typ_addr)) f.params; + fun_body = transl f.body; + fun_fast = !Clflags.optimize_for_speed; + fun_dbg = f.dbg; } (* Translate all function definitions *) @@ -1543,12 +1604,13 @@ module StringSet = let rec transl_all_functions already_translated cont = try - let (lbl, params, body) = Queue.take functions in - if StringSet.mem lbl already_translated then + let f = Queue.take functions in + if StringSet.mem f.label already_translated then transl_all_functions already_translated cont else begin - transl_all_functions (StringSet.add lbl already_translated) - (transl_function lbl params body :: cont) + transl_all_functions + (StringSet.add f.label already_translated) + (transl_function f :: cont) end with Queue.Empty -> cont @@ -1601,11 +1663,11 @@ and emit_constant_field field cont = | Const_base(Const_char c) -> (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) | Const_base(Const_float s) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) | Const_base(Const_string s) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(string_header (String.length s)) :: Cdefine_label lbl :: emit_string_constant s cont) @@ -1613,24 +1675,24 @@ and emit_constant_field field cont = begin try (Clabel_address (Hashtbl.find immstrings s), cont) with Not_found -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in Hashtbl.add immstrings s lbl; (Clabel_address lbl, Cint(string_header (String.length s)) :: Cdefine_label lbl :: emit_string_constant s cont) end | Const_base(Const_int32 n) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(boxedint32_header) :: Cdefine_label lbl :: emit_boxed_int32_constant n cont) | Const_base(Const_int64 n) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(boxedint64_header) :: Cdefine_label lbl :: emit_boxed_int64_constant n cont) | Const_base(Const_nativeint n) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(boxedintnat_header) :: Cdefine_label lbl :: emit_boxed_nativeint_constant n cont) @@ -1638,13 +1700,13 @@ and emit_constant_field field cont = (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), cont) | Const_block(tag, fields) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in let (emit_fields, cont1) = emit_constant_fields fields cont in (Clabel_address lbl, Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: emit_fields @ cont1) | Const_float_array(fields) -> - let lbl = new_const_label() in + let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: Misc.map_end (fun f -> Cdouble f) fields cont) @@ -1680,31 +1742,31 @@ and emit_boxed_int64_constant n cont = let emit_constant_closure symb fundecls cont = match fundecls with [] -> assert false - | (label, arity, params, body) :: remainder -> + | f1 :: remainder -> let rec emit_others pos = function [] -> cont - | (label, arity, params, body) :: rem -> - if arity = 1 then + | f2 :: rem -> + if f2.arity = 1 then Cint(infix_header pos) :: - Csymbol_address label :: + Csymbol_address f2.label :: Cint 3n :: emit_others (pos + 3) rem else Cint(infix_header pos) :: - Csymbol_address(curry_function arity) :: - Cint(Nativeint.of_int (arity lsl 1 + 1)) :: - Csymbol_address label :: + Csymbol_address(curry_function f2.arity) :: + Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: + Csymbol_address f2.label :: emit_others (pos + 4) rem in Cint(closure_header (fundecls_size fundecls)) :: Cdefine_symbol symb :: - if arity = 1 then - Csymbol_address label :: + if f1.arity = 1 then + Csymbol_address f1.label :: Cint 3n :: emit_others 3 remainder else - Csymbol_address(curry_function arity) :: - Cint(Nativeint.of_int (arity lsl 1 + 1)) :: - Csymbol_address label :: + Csymbol_address(curry_function f1.arity) :: + Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) :: + Csymbol_address f1.label :: emit_others 4 remainder (* Emit all structured constants *) @@ -1712,9 +1774,14 @@ let emit_constant_closure symb fundecls cont = let emit_all_constants cont = let c = ref cont in List.iter - (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c) - !structured_constants; - structured_constants := []; + (fun (lbl, global, cst) -> + let cst = emit_constant lbl cst [] in + let cst = if global then + Cglobal_symbol lbl :: cst + else cst in + c:= Cdata(cst):: !c) + (Compilenv.structured_constants()); +(* structured_constants := []; done in Compilenv.reset() *) Hashtbl.clear immstrings; (* PR#3979 *) List.iter (fun (symb, fundecls) -> @@ -1730,7 +1797,8 @@ let compunit size ulam = let init_code = transl ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); fun_args = []; - fun_body = init_code; fun_fast = false}] in + fun_body = init_code; fun_fast = false; + fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in Cdata [Cint(block_header 0 size); @@ -1859,7 +1927,8 @@ let send_function arity = {fun_name = "caml_send" ^ string_of_int arity; fun_args = fun_args; fun_body = body; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } let apply_function arity = let (args, clos, body) = apply_function_body arity in @@ -1868,7 +1937,8 @@ let apply_function arity = {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; fun_body = body; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } (* Generate tuplifying functions: (defun caml_tuplifyN (arg clos) @@ -1887,22 +1957,30 @@ let tuplify_function arity = fun_body = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } (* Generate currying functions: (defun caml_curryN (arg clos) - (alloc HDR caml_curryN_1 arg clos)) + (alloc HDR caml_curryN_1 caml_curry_N_1_app arg clos)) (defun caml_curryN_1 (arg clos) - (alloc HDR caml_curryN_2 arg clos)) + (alloc HDR caml_curryN_2 caml_curry_N_2_app arg clos)) ... (defun caml_curryN_N-1 (arg clos) - (let (closN-2 clos.cdr - closN-3 closN-2.cdr + (let (closN-2 clos.vars[1] + closN-3 closN-2.vars[1] ... - clos1 clos2.cdr - clos clos1.cdr) + clos1 clos2.vars[1] + clos clos1.vars[1]) (app clos.direct - clos1.car clos2.car ... closN-2.car clos.car arg clos))) *) + 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'))) +*) let final_curry_function arity = let last_arg = Ident.create "arg" in @@ -1912,18 +1990,27 @@ let final_curry_function arity = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: args @ [Cvar last_arg; Cvar clos]) - else begin + else + if n = arity - 1 then + begin let newclos = Ident.create "clos" in Clet(newclos, get_field (Cvar clos) 3, curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) + end else + begin + let newclos = Ident.create "clos" in + Clet(newclos, + get_field (Cvar clos) 4, + curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1)) end in Cfunction {fun_name = "caml_curry" ^ string_of_int arity ^ "_" ^ string_of_int (arity-1); fun_args = [last_arg, typ_addr; last_clos, typ_addr]; fun_body = curry_fun [] last_clos (arity-1); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } let rec intermediate_curry_functions arity num = if num = arity - 1 then @@ -1935,12 +2022,52 @@ let rec intermediate_curry_functions arity num = Cfunction {fun_name = name2; fun_args = [arg, typ_addr; clos, typ_addr]; - fun_body = Cop(Calloc, + fun_body = + if arity - num > 2 then + Cop(Calloc, + [alloc_closure_header 5; + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); + int_const (arity - num - 1); + Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app"); + Cvar arg; Cvar clos]) + else + Cop(Calloc, [alloc_closure_header 4; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const 1; Cvar arg; Cvar clos]); - fun_fast = true} - :: intermediate_curry_functions arity (num+1) + fun_fast = true; + fun_dbg = Debuginfo.none } + :: + (if arity - num > 2 then + let rec iter i = + if i <= arity then + let arg = Ident.create (Printf.sprintf "arg%d" i) in + (arg, typ_addr) :: iter (i+1) + else [] + in + let direct_args = iter (num+2) in + let rec iter i args clos = + if i = 0 then + Cop(Capply(typ_addr, Debuginfo.none), + (get_field (Cvar clos) 2) :: args @ [Cvar clos]) + else + let newclos = Ident.create "clos" in + Clet(newclos, + get_field (Cvar clos) 4, + iter (i-1) (get_field (Cvar clos) 3 :: args) newclos) + in + let cf = + Cfunction + {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; + fun_args = direct_args @ [clos, typ_addr]; + fun_body = iter (num+1) + (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; + fun_fast = true; + fun_dbg = Debuginfo.none } + in + cf :: intermediate_curry_functions arity (num+1) + else + intermediate_curry_functions arity (num+1)) end let curry_function arity = @@ -1992,7 +2119,8 @@ let entry_point namelist = Cfunction {fun_name = "caml_program"; fun_args = []; fun_body = body; - fun_fast = false} + fun_fast = false; + fun_dbg = Debuginfo.none } (* Generate the table of globals *) diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index ba7e5ad0..a192b985 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index a43a21df..69cd3823 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) @@ -16,12 +16,12 @@ (* Each .o file has a matching .cmx file that provides the following infos on the compilation unit: - - list of other units imported, with CRCs of their .cmx files + - list of other units imported, with MD5s of their .cmx files - approximation of the structure implemented (includes descriptions of known functions: arity and direct entry points) - list of currying functions and application functions needed - The .cmx file contains these infos (as an externed record) plus a CRC + The .cmx file contains these infos (as an externed record) plus a MD5 of these infos *) type unit_infos = @@ -40,7 +40,7 @@ type unit_infos = infos on the library: *) type library_infos = - { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ CRCs *) + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) lib_ccobjs: string list; (* C object files needed *) lib_ccopts: string list } (* Extra opts to C compiler *) diff --git a/asmcomp/codegen.ml b/asmcomp/codegen.ml index 280f1394..4b71503f 100644 --- a/asmcomp/codegen.ml +++ b/asmcomp/codegen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/codegen.mli b/asmcomp/codegen.mli index b6d8caa6..43f98e50 100644 --- a/asmcomp/codegen.mli +++ b/asmcomp/codegen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index 37c03a05..06c1eb82 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/coloring.mli b/asmcomp/coloring.mli index cbfb2d6c..72576fa1 100644 --- a/asmcomp/coloring.mli +++ b/asmcomp/coloring.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 13dbcaff..9767d263 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/comballoc.mli b/asmcomp/comballoc.mli index 329e9276..20be9805 100644 --- a/asmcomp/comballoc.mli +++ b/asmcomp/comballoc.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index cf5001dc..4c6e72d0 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -29,6 +29,8 @@ 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 current_unit = { ui_name = ""; ui_symbol = ""; @@ -55,6 +57,7 @@ let symbolname_for_pack pack name = Buffer.add_string b name; Buffer.contents b + let reset ?packname name = Hashtbl.clear global_infos_table; let symbol = symbolname_for_pack packname name in @@ -66,7 +69,8 @@ let reset ?packname name = current_unit.ui_curry_fun <- []; current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; - current_unit.ui_force_link <- false + current_unit.ui_force_link <- false; + structured_constants := [] let current_unit_infos () = current_unit @@ -83,8 +87,7 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt = let read_unit_info filename = let ic = open_in_bin filename in try - let buffer = String.create (String.length cmx_magic_number) in - really_input ic buffer 0 (String.length cmx_magic_number); + let buffer = input_bytes ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) @@ -99,8 +102,7 @@ let read_unit_info filename = let read_library_info filename = let ic = open_in_bin filename in - let buffer = String.create (String.length cmxa_magic_number) in - really_input ic buffer 0 (String.length cmxa_magic_number); + let buffer = input_bytes ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in @@ -200,14 +202,36 @@ let save_unit_info filename = current_unit.ui_imports_cmi <- Env.imported_units(); write_unit_info current_unit filename + + +let const_label = ref 0 + +let new_const_label () = + incr const_label; + !const_label + +let new_const_symbol () = + incr const_label; + make_symbol (Some (string_of_int !const_label)) + +let new_structured_constant cst global = + let lbl = new_const_symbol() in + structured_constants := (lbl, global, cst) :: !structured_constants; + lbl + +let structured_constants () = !structured_constants + (* Error report *) open Format let report_error ppf = function | Not_a_unit_info filename -> - fprintf ppf "%s@ is not a compilation unit description." filename + fprintf ppf "%a@ is not a compilation unit description." + Location.print_filename filename | Corrupted_unit_info filename -> - fprintf ppf "Corrupted compilation unit description@ %s" filename + fprintf ppf "Corrupted compilation unit description@ %a" + Location.print_filename filename | Illegal_renaming(modname, filename) -> - fprintf ppf "%s@ contains the description for unit@ %s" filename modname + fprintf ppf "%a@ contains the description for unit@ %s" + Location.print_filename filename modname diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 4d43e1f8..3e4d83e2 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -51,9 +51,13 @@ val need_send_fun: int -> unit (* Record the need of a currying (resp. application, message sending) function with the given arity *) +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 read_unit_info: string -> unit_infos * Digest.t - (* Read infos and CRC from a [.cmx] file. *) + (* Read infos and MD5 from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit (* Save the given infos in the given file *) val save_unit_info: string -> unit diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml index a7124e17..ab0f5c04 100644 --- a/asmcomp/debuginfo.ml +++ b/asmcomp/debuginfo.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) @@ -31,6 +31,9 @@ let none = { dinfo_char_end = 0 } +let is_none t = + t == none + let to_string d = if d == none then "" @@ -38,7 +41,7 @@ let to_string d = d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end let from_location kind loc = - if loc.loc_ghost then none else + if loc == Location.none then none else { dinfo_kind = kind; dinfo_file = loc.loc_start.pos_fname; dinfo_line = loc.loc_start.pos_lnum; @@ -50,3 +53,4 @@ let from_location kind loc = let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc + diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli index c3c9c406..cf6179cd 100644 --- a/asmcomp/debuginfo.mli +++ b/asmcomp/debuginfo.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) @@ -22,6 +22,8 @@ type t = { val none: t +val is_none: t -> bool + val to_string: t -> string val from_location: kind -> Location.t -> t diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli index ab7657af..e2ff68ff 100644 --- a/asmcomp/emit.mli +++ b/asmcomp/emit.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index d4db78ad..712b848f 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -114,6 +114,36 @@ let emit_float32_directive directive f = let x = Int32.bits_of_float (float_of_string f) in emit_printf "\t%s\t0x%lx\n" directive x +(* Emit debug information *) + +(* This assoc list is expected to be very short *) +let file_pos_nums = + (ref [] : (string * int) list ref) + +(* Number of files *) +let file_pos_num_cnt = ref 1 + +(* We only diplay .file if the file has not been seen before. We + display .loc for every instruction. *) +let emit_debug_info dbg = + let line = dbg.Debuginfo.dinfo_line in + let file_name = dbg.Debuginfo.dinfo_file in + if !Clflags.debug && not (Debuginfo.is_none dbg) then ( + let file_num = + try List.assoc file_name !file_pos_nums + with Not_found -> + let file_num = !file_pos_num_cnt in + incr file_pos_num_cnt; + emit_string " .file "; + emit_int file_num; emit_char ' '; + emit_string_literal file_name; emit_char '\n'; + file_pos_nums := (file_name,file_num) :: !file_pos_nums; + file_num in + emit_string " .loc "; + emit_int file_num; emit_char ' '; + emit_int line; emit_char '\n' + ) + (* Record live pointers at call points *) type frame_descr = @@ -189,3 +219,23 @@ let is_generic_function name = List.exists (fun p -> isprefix p name) ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"] + +(* CFI directives *) + +let is_cfi_enabled () = + !Clflags.debug && Config.asm_cfi_supported + +let cfi_startproc () = + if is_cfi_enabled () then + emit_string " .cfi_startproc\n" + +let cfi_endproc () = + if is_cfi_enabled () then + emit_string " .cfi_endproc\n" + +let cfi_adjust_cfa_offset n = + if is_cfi_enabled () then + begin + emit_string " .cfi_adjust_cfa_offset "; emit_int n; emit_string "\n"; + end + diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 4f666be7..dd2f5b8c 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -29,6 +29,8 @@ val emit_float64_directive: string -> string -> unit val emit_float64_split_directive: string -> string -> unit val emit_float32_directive: string -> string -> unit +val emit_debug_info: Debuginfo.t -> unit + type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) @@ -50,3 +52,7 @@ type emit_frame_actions = val emit_frames: emit_frame_actions -> unit val is_generic_function: string -> bool + +val cfi_startproc : unit -> unit +val cfi_endproc : unit -> unit +val cfi_adjust_cfa_offset : int -> unit diff --git a/asmcomp/hppa/arch.ml b/asmcomp/hppa/arch.ml deleted file mode 100644 index eb2e1938..00000000 --- a/asmcomp/hppa/arch.ml +++ /dev/null @@ -1,73 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Specific operations for the HP PA-RISC processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Specific operations *) - -type specific_operation = - Ishift1add - | Ishift2add - | Ishift3add - -(* Addressing modes *) - -type addressing_mode = - Ibased of string * int (* symbol + displ *) - | Iindexed of int (* reg + displ *) - -(* Sizes, endianness *) - -let big_endian = true - -let size_addr = 4 -let size_int = 4 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed 0 - -let offset_addressing addr delta = - match addr with - Ibased(s, n) -> Ibased(s, n + delta) - | Iindexed n -> Iindexed(n + delta) - -let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - match addr with - | Ibased(s, n) -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "\"%s\"%s" s idx - | Iindexed n -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "%a%s" printreg arg.(0) idx - -let print_specific_operation printreg op ppf arg = - match op with - | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1) - | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1) - | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1) diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp deleted file mode 100644 index b697a335..00000000 --- a/asmcomp/hppa/emit.mlp +++ /dev/null @@ -1,1042 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Emission of HP PA-RISC assembly code *) - -(* Must come before open Reg... *) -module StringSet = - Set.Make(struct - type t = string - let compare = compare - end) - -open Location -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Layout of the stack *) -(* Always keep the stack 8-aligned. *) - -let stack_offset = ref 0 - -let frame_size () = - let size = - !stack_offset + - 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + - (if !contains_calls then 4 else 0) in - Misc.align size 8 - -let slot_offset loc cl = - match loc with - Incoming n -> -frame_size() - n - | Local n -> - if cl = 0 - then - !stack_offset - num_stack_slots.(1) * 8 - n * 4 - 4 - else - !stack_offset - n * 8 - 8 - | Outgoing n -> -n - -(* Output a label *) - -let emit_label lbl = - emit_string "L$"; emit_int lbl - -(* Output a symbol *) - -let emit_symbol s = - Emitaux.emit_symbol '$' s - -(* Output a pseudo-register *) - -let emit_reg r = - match r.loc with - Reg r -> emit_string (register_name r) - | _ -> assert false - -(* Output low address / high address prefixes *) - -let low_prefix = "RR%" -let high_prefix = "LR%" - -let is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) - -let emit_int_low n = emit_string low_prefix; emit_int n -let emit_int_high n = emit_string high_prefix; emit_int n - -let emit_nativeint_low n = emit_string low_prefix; emit_nativeint n -let emit_nativeint_high n = emit_string high_prefix; emit_nativeint n - -let emit_symbol_low s = - `RR%{emit_symbol s}-$global$` - -let load_symbol_high s = - ` addil LR%{emit_symbol s}-$global$, %r27\n` - -let load_symbol_offset_high s ofs = - ` addil LR%{emit_symbol s}-$global$+{emit_int ofs}, %r27\n` - -(* Record imported and defined symbols *) - -let used_symbols = ref StringSet.empty -let defined_symbols = ref StringSet.empty -let called_symbols = ref StringSet.empty - -let use_symbol s = - used_symbols := StringSet.add s !used_symbols -let define_symbol s = - defined_symbols := StringSet.add s !defined_symbols -let call_symbol s = - used_symbols := StringSet.add s !used_symbols; - called_symbols := StringSet.add s !called_symbols - -(* An external symbol is code if either it is branched to, or - it is one of the caml_apply* caml_curry* caml_tuplify* special functions. *) - -let code_imports = ["caml_apply"; "caml_curry"; "caml_tuplify"] - -let match_prefix s pref = - String.length s >= String.length pref - && String.sub s 0 (String.length pref) = pref - -let emit_import s = - if not(StringSet.mem s !defined_symbols) then begin - ` .import {emit_symbol s}`; - if StringSet.mem s !called_symbols - || List.exists (match_prefix s) code_imports - then `, code\n` - else `, data\n` - end - -let emit_imports () = - StringSet.iter emit_import !used_symbols; - used_symbols := StringSet.empty; - defined_symbols := StringSet.empty; - called_symbols := StringSet.empty - -(* Output an integer load / store *) - -let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *) - -let is_offset_native n = - n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192) - -let emit_load instr addr arg dst = - match addr with - Ibased(s, 0) -> - use_symbol s; - load_symbol_high s; - ` {emit_string instr} {emit_symbol_low s}(%r1), {emit_reg dst}\n` - | Ibased(s, ofs) -> - use_symbol s; - load_symbol_offset_high s ofs; - ` {emit_string instr} {emit_symbol_low s}+{emit_int ofs}(%r1), {emit_reg dst}\n` - | Iindexed ofs -> - if is_offset ofs then - ` {emit_string instr} {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}\n` - else begin - ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; - ` {emit_string instr} {emit_int_low ofs}(%r1), {emit_reg dst}\n` - end - -let emit_store instr addr arg src = - match addr with - Ibased(s, 0) -> - use_symbol s; - load_symbol_high s; - ` {emit_string instr} {emit_reg src}, {emit_symbol_low s}(%r1)\n` - | Ibased(s, ofs) -> - use_symbol s; - load_symbol_offset_high s ofs; - ` {emit_string instr} {emit_reg src}, {emit_symbol_low s}+{emit_int ofs}(%r1)\n` - | Iindexed ofs -> - if is_offset ofs then - ` {emit_string instr} {emit_reg src}, {emit_int ofs}({emit_reg arg.(1)})\n` - else begin - ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; - ` {emit_string instr} {emit_reg src}, {emit_int_low ofs}(%r1)\n` - end - -(* Output a floating-point load / store *) - -let emit_float_load addr arg dst doubleword = - match addr with - Ibased(s, 0) -> - use_symbol s; - load_symbol_high s; - ` ldo {emit_symbol_low s}(%r1), %r1\n`; - ` fldws 0(%r1), {emit_reg dst}L\n`; - if doubleword then - ` fldws 4(%r1), {emit_reg dst}R\n` - | Ibased(s, ofs) -> - use_symbol s; - load_symbol_offset_high s ofs; - ` ldo {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`; - ` fldws 0(%r1), {emit_reg dst}L\n`; - if doubleword then - ` fldws 4(%r1), {emit_reg dst}R\n` - | Iindexed ofs -> - if is_immediate ofs && (is_immediate (ofs+4) || not doubleword) - then begin - ` fldws {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}L\n`; - if doubleword then - ` fldws {emit_int (ofs+4)}({emit_reg arg.(0)}), {emit_reg dst}R\n` - end else begin - if is_offset ofs then - ` ldo {emit_int ofs}({emit_reg arg.(0)}), %r1\n` - else begin - ` addil {emit_int_high ofs}, {emit_reg arg.(0)}\n`; - ` ldo {emit_int_low ofs}(%r1), %r1\n` - end; - ` fldws 0(%r1), {emit_reg dst}L\n`; - if doubleword then - ` fldws 4(%r1), {emit_reg dst}R\n` - end - -let emit_float_store addr arg src doubleword = - match addr with - Ibased(s, 0) -> - use_symbol s; - load_symbol_high s; - ` ldo {emit_symbol_low s}(%r1), %r1\n`; - ` fstws {emit_reg src}L, 0(%r1)\n`; - if doubleword then - ` fstws {emit_reg src}R, 4(%r1)\n` - | Ibased(s, ofs) -> - use_symbol s; - load_symbol_offset_high s ofs; - ` ldo {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`; - ` fstws {emit_reg src}L, 0(%r1)\n`; - if doubleword then - ` fstws {emit_reg src}R, 4(%r1)\n` - | Iindexed ofs -> - if is_immediate ofs && (is_immediate (ofs+4) || not doubleword) - then begin - ` fstws {emit_reg src}L, {emit_int ofs}({emit_reg arg.(1)})\n`; - if doubleword then - ` fstws {emit_reg src}R, {emit_int(ofs+4)}({emit_reg arg.(1)})\n` - end else begin - if is_offset ofs then - ` ldo {emit_int ofs}({emit_reg arg.(1)}), %r1\n` - else begin - ` addil {emit_int_high ofs}, {emit_reg arg.(1)}\n`; - ` ldo {emit_int_low ofs}(%r1), %r1\n` - end; - ` fstws {emit_reg src}L, 0(%r1)\n`; - if doubleword then - ` fstws {emit_reg src}R, 4(%r1)\n` - end - -(* Output an align directive. *) - -let emit_align n = - ` .align {emit_int n}\n` - -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame live = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:\n` - -let emit_frame fd = - ` .long {emit_label fd.fd_lbl} + 3\n`; - ` .short {emit_int fd.fd_frame_size}\n`; - ` .short {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .short {emit_int n}\n`) - fd.fd_live_offset; - emit_align 4 - -(* Record floating-point constants *) - -let float_constants = ref ([] : (int * string) list) - -let emit_float_constants () = - if Config.system = "hpux" then begin - ` .space $TEXT$\n`; - ` .subspa $LIT$\n` - end else - ` .text\n`; - emit_align 8; - List.iter - (fun (lbl, cst) -> - `{emit_label lbl}:`; - emit_float64_split_directive ".long" cst) - !float_constants; - float_constants := [] - -(* Describe the registers used to pass arguments to a C function *) - -let describe_call arg = - ` .CALL RTNVAL=NO`; - let pos = ref 0 in - for i = 0 to Array.length arg - 1 do - if !pos < 4 then begin - match arg.(i).typ with - Float -> `, ARGW{emit_int !pos}=FR, ARGW{emit_int(!pos + 1)}=FU`; - pos := !pos + 2 - | _ -> `, ARGW{emit_int !pos}=GR`; - pos := !pos + 1 - end - done; - `\n` - -(* Output a function call *) - -let emit_call s retreg = - call_symbol s; - ` bl {emit_symbol s}, {emit_string retreg}\n` - -(* Names of various instructions *) - -let name_for_int_operation = function - Iadd -> "add" - | Isub -> "sub" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | _ -> assert false - -let name_for_float_operation = function - Iaddf -> "fadd,dbl" - | Isubf -> "fsub,dbl" - | Imulf -> "fmpy,dbl" - | Idivf -> "fdiv,dbl" - | _ -> assert false - -let name_for_specific_operation = function - Ishift1add -> "sh1add" - | Ishift2add -> "sh2add" - | Ishift3add -> "sh3add" - -let name_for_int_comparison = function - Isigned Ceq -> "=" | Isigned Cne -> "<>" - | Isigned Cle -> "<=" | Isigned Cgt -> ">" - | Isigned Clt -> "<" | Isigned Cge -> ">=" - | Iunsigned Ceq -> "=" | Iunsigned Cne -> "<>" - | Iunsigned Cle -> "<<=" | Iunsigned Cgt -> ">>" - | Iunsigned Clt -> "<<" | Iunsigned Cge -> ">>=" - -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> if neg then "=" else "!=" - | Cne -> if neg then "!=" else "=" - | Cle -> if neg then "<=" else "!<=" - | Cgt -> if neg then ">" else "!>" - | Clt -> if neg then "<" else "!<" - | Cge -> if neg then ">=" else "!>=" - -let negate_int_comparison = function - Isigned cmp -> Isigned(Cmm.negate_comparison cmp) - | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp) - -let swap_int_comparison = function - Isigned cmp -> Isigned(Cmm.swap_comparison cmp) - | Iunsigned cmp -> Iunsigned(Cmm.swap_comparison cmp) - - -(* Output the assembly code for an instruction *) - -(* Name of current function *) -let function_name = ref "" -(* Entry point for tail recursive calls *) -let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 - -let rec emit_instr i dslot = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - begin match (src, dst) with - {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> - ` copy {emit_reg src}, {emit_reg dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> - ` fcpy,dbl {emit_reg src}, {emit_reg dst}\n` - | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> - let ofs = slot_offset sd 0 in - ` stw {emit_reg src}, {emit_int ofs}(%r30)\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> - let ofs = slot_offset sd 1 in - if is_immediate ofs then - ` fstds {emit_reg src}, {emit_int ofs}(%r30)\n` - else begin - ` ldo {emit_int ofs}(%r30), %r1\n`; - ` fstds {emit_reg src}, 0(%r1)\n` - end - | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> - let ofs = slot_offset ss 0 in - ` ldw {emit_int ofs}(%r30), {emit_reg dst}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> - let ofs = slot_offset ss 1 in - if is_immediate ofs then - ` fldds {emit_int ofs}(%r30), {emit_reg dst}\n` - else begin - ` ldo {emit_int ofs}(%r30), %r1\n`; - ` fldds 0(%r1), {emit_reg dst}\n` - end - | (_, _) -> - assert false - end - | Lop(Iconst_int n) -> - if is_offset_native n then - ` ldi {emit_nativeint n}, {emit_reg i.res.(0)}\n` - else begin - ` ldil {emit_nativeint_high n}, {emit_reg i.res.(0)}\n`; - ` ldo {emit_nativeint_low n}({emit_reg i.res.(0)}), {emit_reg i.res.(0)}\n` - end - | Lop(Iconst_float s) -> - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; - ` ldil {emit_string high_prefix}{emit_label lbl}, %r1\n`; - ` ldo {emit_string low_prefix}{emit_label lbl}(%r1), %r1\n`; - ` fldds 0(%r1), {emit_reg i.res.(0)}\n` - | Lop(Iconst_symbol s) -> - use_symbol s; - load_symbol_high s; - ` ldo {emit_symbol_low s}(%r1), {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - ` ble 0(4, {emit_reg i.arg.(0)})\n`; (* retaddr in %r31 *) - ` copy %r31, %r2\n`; (* in delay slot: save retaddr in %r2 *) - record_frame i.live - | Lop(Icall_imm s) -> - emit_call s "%r2"; - fill_delay_slot dslot; - record_frame i.live - | Lop(Itailcall_ind) -> - let n = frame_size() in - ` bv 0({emit_reg i.arg.(0)})\n`; - if !contains_calls (* in delay slot *) - then ` ldwm {emit_int(-n)}(%r30), %r2\n` - else ` ldo {emit_int(-n)}(%r30), %r30\n` - | Lop(Itailcall_imm s) -> - let n = frame_size() in - if s = !function_name then begin - ` b,n {emit_label !tailrec_entry_point}\n` - end else begin - emit_call s "%r0"; - if !contains_calls (* in delay slot *) - then ` ldwm {emit_int(-n)}(%r30), %r2\n` - else ` ldo {emit_int(-n)}(%r30), %r30\n` - end - | Lop(Iextcall(s, alloc)) -> - call_symbol s; - if alloc then begin - ` ldil LR%{emit_symbol s}, %r22\n`; - describe_call i.arg; - emit_call "caml_c_call" "%r2"; - ` ldo RR%{emit_symbol s}(%r22), %r22\n`; (* in delay slot *) - record_frame i.live - end else begin - describe_call i.arg; - emit_call s "%r2"; - fill_delay_slot dslot - end - | Lop(Istackoffset n) -> - ` ldo {emit_int n}(%r30), %r30\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - Byte_unsigned -> - emit_load "ldb" addr i.arg dest - | Byte_signed -> - emit_load "ldb" addr i.arg dest; - ` extrs {emit_reg dest}, 31, 8, {emit_reg dest}\n` - | Sixteen_unsigned -> - emit_load "ldh" addr i.arg dest - | Sixteen_signed -> - emit_load "ldh" addr i.arg dest; - ` extrs {emit_reg dest}, 31, 16, {emit_reg dest}\n` - | Single -> - emit_float_load addr i.arg dest false; - ` fcnvff,sgl,dbl {emit_reg dest}L, {emit_reg dest}\n` - | Double | Double_u -> - emit_float_load addr i.arg dest true - | _ -> - emit_load "ldw" addr i.arg dest - end - | Lop(Istore(chunk, addr)) -> - let src = i.arg.(0) in - begin match chunk with - Byte_unsigned | Byte_signed -> - emit_store "stb" addr i.arg src - | Sixteen_unsigned | Sixteen_signed -> - emit_store "sth" addr i.arg src - | Single -> - ` fcnvff,dbl,sgl {emit_reg src}, %fr31L\n`; - emit_float_store addr i.arg (phys_reg 127) (* %fr31 *) false - | Double | Double_u -> - emit_float_store addr i.arg src true - | _ -> - emit_store "stw" addr i.arg src - end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_cont = new_label() in - ` ldw 0(%r4), %r1\n`; - ` ldo {emit_int (-n)}(%r3), %r3\n`; - ` comb,>>= %r3, %r1, {emit_label lbl_cont}\n`; - ` addi 4, %r3, {emit_reg i.res.(0)}\n`; (* in delay slot *) - emit_call "caml_call_gc" "%r2"; - (* Cannot use %r1 to pass size, since clobbered by glue call code *) - ` ldi {emit_int n}, %r29\n`; (* in delay slot *) - record_frame i.live; - ` addi 4, %r3, {emit_reg i.res.(0)}\n`; - `{emit_label lbl_cont}:\n` - end else begin - emit_call "caml_allocN" "%r2"; - (* Cannot use %r1 either *) - ` ldi {emit_int n}, %r29\n`; (* in delay slot *) - record_frame i.live; - ` addi 4, %r3, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop Imul) -> - ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; - ` stw {emit_reg i.arg.(1)}, -4(%r30)\n`; - ` fldws -8(%r30), %fr31L\n`; - ` fldws -4(%r30), %fr31R\n`; - ` xmpyu %fr31L, %fr31R, %fr31\n`; - ` fstws %fr31R, -8(%r30)\n`; (* poor scheduling *) - ` ldws,mb -8(%r30), {emit_reg i.res.(0)}\n` - | Lop(Iintop Idiv) -> - (* Arguments are assumed to be in %r26 and %r25, result in %r29 *) - ` bl $$divI, %r31\n`; - fill_delay_slot dslot - | Lop(Iintop Imod) -> - (* Arguments are assumed to be in %r26 and %r25, result in %r29 *) - ` bl $$remI, %r31\n`; - fill_delay_slot dslot - | Lop(Iintop Ilsl) -> - ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; - ` mtsar %r1\n`; - ` zvdep {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n` - | Lop(Iintop Ilsr) -> - ` mtsar {emit_reg i.arg.(1)}\n`; - ` vshd %r0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop Iasr) -> - ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; - ` mtsar %r1\n`; - ` vextrs {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n` - | Lop(Iintop(Icomp cmp)) -> - let comp = name_for_int_comparison(negate_int_comparison cmp) in - ` comclr,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; - ` ldi 1, {emit_reg i.res.(0)}\n` - | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` comclr,>> {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %r0\n`; - ` b,n {emit_label !range_check_trap}\n` - | Lop(Iintop op) -> - let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, n)) -> - ` addi {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Isub, n)) -> - ` addi {emit_int(-n)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - ` comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`; - if not (l = 0) then - ` zdepi -1, 31, {emit_int l}, %r1\n` - else - ` xor %r1, %r1, %r1\n`; - ` add {emit_reg i.arg.(0)}, %r1, %r1\n`; - ` extrs %r1, {emit_int(31-l)}, {emit_int(32-l)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - let l = Misc.log2 n in - ` comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`; - if not (l = 0) then - ` zdepi -1, 31, {emit_int l}, %r1\n` - else - ` xor %r1, %r1, %r1\n`; - ` add {emit_reg i.arg.(0)}, %r1, %r1\n`; - ` depi 0, 31, {emit_int l}, %r1\n`; - ` sub {emit_reg i.arg.(0)}, %r1, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Ilsl, n)) -> - let n = n land 31 in - ` zdep {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Ilsr, n)) -> - let n = n land 31 in - ` extru {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iasr, n)) -> - let n = n land 31 in - ` extrs {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - let comp = name_for_int_comparison(negate_int_comparison(swap_int_comparison cmp)) in - ` comiclr,{emit_string comp} {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; - ` ldi 1, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` comiclr,<< {emit_int n}, {emit_reg i.arg.(0)}, %r0\n`; - ` b,n {emit_label !range_check_trap}\n` - | Lop(Iintop_imm(op, n)) -> - assert false - | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> - let instr = name_for_float_operation op in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Inegf) -> - ` fsub,dbl 0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iabsf) -> - ` fabs,dbl {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Ifloatofint) -> - ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; - ` fldws,mb -8(%r30), %fr31L\n`; - ` fcnvxf,sgl,dbl %fr31L, {emit_reg i.res.(0)}\n` - | Lop(Iintoffloat) -> - ` fcnvfxt,dbl,sgl {emit_reg i.arg.(0)}, %fr31L\n`; - ` fstws,ma %fr31L, 8(%r30)\n`; - ` ldws,mb -8(%r30), {emit_reg i.res.(0)}\n` - | Lop(Ispecific sop) -> - let instr = name_for_specific_operation sop in - ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lreloadretaddr -> - let n = frame_size() in - ` ldw {emit_int(-n)}(%r30), %r2\n` - | Lreturn -> - let n = frame_size() in - ` bv 0(%r2)\n`; - ` ldo {emit_int(-n)}(%r30), %r30\n` (* in delay slot *) - | Llabel lbl -> - `{emit_label lbl}:\n` - | Lbranch lbl -> - begin match dslot with - None -> - ` b,n {emit_label lbl}\n` - | Some i -> - ` b {emit_label lbl}\n`; - emit_instr i None - end - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - emit_comib "<>" "=" 0 i.arg lbl dslot - | Ifalsetest -> - emit_comib "=" "<>" 0 i.arg lbl dslot - | Iinttest cmp -> - let comp = name_for_int_comparison cmp - and negcomp = - name_for_int_comparison(negate_int_comparison cmp) in - emit_comb comp negcomp i.arg lbl dslot - | Iinttest_imm(cmp, n) -> - let scmp = swap_int_comparison cmp in - let comp = name_for_int_comparison scmp - and negcomp = - name_for_int_comparison(negate_int_comparison scmp) in - emit_comib comp negcomp n i.arg lbl dslot - | Ifloattest(cmp, neg) -> - let comp = name_for_float_comparison cmp neg in - ` fcmp,dbl,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` ftest\n`; - ` b {emit_label lbl}\n`; - fill_delay_slot dslot - | Ioddtest -> - emit_comib "OD" "EV" 0 i.arg lbl dslot - | Ieventest -> - emit_comib "EV" "OD" 0 i.arg lbl dslot - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - begin match lbl0 with - None -> () - | Some lbl -> emit_comib "=" "<>" 0 i.arg lbl None - end; - begin match lbl1 with - None -> () - | Some lbl -> emit_comib "=" "<>" 1 i.arg lbl None - end; - begin match lbl2 with - None -> () - | Some lbl -> emit_comib "=" "<>" 2 i.arg lbl None - end - | Lswitch jumptbl -> - ` blr {emit_reg i.arg.(0)}, 0\n`; - fill_delay_slot dslot; - for i = 0 to Array.length jumptbl - 1 do - ` b {emit_label jumptbl.(i)}\n`; - ` nop\n` - done - | Lsetuptrap lbl -> - ` bl {emit_label lbl}, %r1\n`; - fill_delay_slot dslot - | Lpushtrap -> - stack_offset := !stack_offset + 8; - ` stws,ma %r5, 8(%r30)\n`; - ` stw %r1, -4(%r30)\n`; - ` copy %r30, %r5\n` - | Lpoptrap -> - ` ldws,mb -8(%r30), %r5\n`; - stack_offset := !stack_offset - 8 - | Lraise -> - ` ldw -4(%r5), %r1\n`; - ` copy %r5, %r30\n`; - ` bv 0(%r1)\n`; - ` ldws,mb -8(%r30), %r5\n` (* in delay slot *) - -and fill_delay_slot = function - None -> ` nop\n` - | Some i -> emit_instr i None - -and emit_delay_slot = function - None -> () - | Some i -> emit_instr i None - -and emit_comb comp negcomp arg lbl dslot = - if lbl >= 0 then begin - ` comb,{emit_string comp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, {emit_label lbl}\n`; - fill_delay_slot dslot - end else begin - emit_delay_slot dslot; - ` comclr,{emit_string negcomp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, %r0\n`; - ` b,n {emit_label (-lbl)}\n` - end - -and emit_comib comp negcomp cst arg lbl dslot = - if lbl >= 0 then begin - ` comib,{emit_string comp} {emit_int cst}, {emit_reg arg.(0)}, {emit_label lbl}\n`; - fill_delay_slot dslot - end else begin - emit_delay_slot dslot; - ` comiclr,{emit_string negcomp} {emit_int cst}, {emit_reg arg.(0)}, %r0\n`; - ` b,n {emit_label (-lbl)}\n` - end - -(* Checks if a pseudo-instruction expands to exactly one machine instruction - that does not branch. *) - -let is_one_instr i = - match i.desc with - Lop op -> - begin match op with - Imove | Ispill | Ireload -> - begin match (i.arg.(0), i.res.(0)) with - ({typ = Float; loc = Stack s}, _) -> is_immediate(slot_offset s 1) - | (_, {typ = Float; loc = Stack s}) -> is_immediate(slot_offset s 1) - | (_, _) -> true - end - | Iconst_int n -> is_offset_native n - | Istackoffset _ -> true - | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_offset n - | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_offset n - | Iintop(Iadd | Isub | Iand | Ior | Ixor) -> true - | Iintop_imm((Iadd | Isub | Ilsl | Ilsr | Iasr), _) -> true - | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf -> true - | Ispecific _ -> true - | _ -> false - end - | Lreloadretaddr -> true - | _ -> false - -let no_interference res arg = - try - for i = 0 to Array.length arg - 1 do - for j = 0 to Array.length res - 1 do - if arg.(i).loc = res.(j).loc then raise Exit - done - done; - true - with Exit -> - false - -(* Emit a sequence of instructions, trying to fill delay slots for branches *) - -let rec emit_all i = - match i with - {desc = Lend} -> () - | {next = {desc = Lop(Icall_imm _) - | Lop(Iextcall(_, false)) - | Lop(Iintop(Idiv | Imod)) - | Lbranch _ - | Lsetuptrap _ }} - when is_one_instr i -> - emit_instr i.next (Some i); - emit_all i.next.next - | {next = {desc = Lcondbranch(_, _) | Lswitch _}} - when is_one_instr i & no_interference i.res i.next.arg -> - emit_instr i.next (Some i); - emit_all i.next.next - | _ -> - emit_instr i None; - emit_all i.next - -(* Estimate the size of an instruction, in actual HPPA instructions *) - -let is_float_stack r = - match r with {loc = Stack _; typ = Float} -> true | _ -> false - -let sizeof_instr i = - match i.desc with - Lend -> 0 - | Lop op -> - begin match op with - Imove | Ispill | Ireload -> - if is_float_stack i.arg.(0) || is_float_stack i.res.(0) - then 2 (* ldo/fxxx *) else 1 - | Iconst_int n -> - if is_offset_native n then 1 else 2 (* ldi or ldil/ldo *) - | Iconst_float _ -> 3 (* ldil/ldo/fldds *) - | Iconst_symbol _ -> 2 (* addil/ldo *) - | Icall_ind -> 2 (* ble/copy *) - | Icall_imm _ -> 2 (* bl/nop *) - | Itailcall_ind -> 2 (* bv/ldwm *) - | Itailcall_imm _ -> 2 (* bl/ldwm *) - | Iextcall(_, alloc) -> - if alloc then 3 (* ldil/bl/ldo *) else 2 (* bl/nop *) - | Istackoffset _ -> 1 (* ldo *) - | Iload(chunk, addr) -> - if i.res.(0).typ = Float - then 4 (* addil/ldo/fldws/fldws *) - else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2) - + (match chunk with Byte_signed -> 1 | Sixteen_signed -> 1 | _ -> 0) - | Istore(chunk, addr) -> - if i.arg.(0).typ = Float - then 4 (* addil/ldo/fstws/fstws *) - else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2) - | Ialloc _ -> if !fastcode_flag then 7 else 3 - | Iintop Imul -> 7 - | Iintop(Idiv | Imod) -> 3 (* ldil/ble/nop *) - | Iintop Ilsl -> 3 (* subi/mtsar/zvdep *) - | Iintop Ilsr -> 2 (* mtsar/vshd *) - | Iintop Iasr -> 3 (* subi/mtsar/vextrs *) - | Iintop(Icomp _) -> 2 (* comclr/ldi *) - | Iintop Icheckbound -> 2 (* comclr/b,n *) - | Iintop _ -> 1 - | Iintop_imm(Idiv, _) -> 4 (* comclr/zdepi/add/extrs *) - | Iintop_imm(Imod, _) -> 5 (* comclr/zdepi/add/extrs/sub *) - | Iintop_imm(Icomp _, _) -> 2 (* comiclr/ldi *) - | Iintop_imm(Icheckbound, _) -> 2 (* comiclr/b,n *) - | Iintop_imm(_, _) -> 1 - | Ifloatofint -> 3 (* stws,ma/fldws,mb/fcnvxf *) - | Iintoffloat -> 3 (* fcnfxt/fstws/ldws *) - | _ (* Inegf|Iabsf|Iaddf|Isubf|Imulf|Idivf|Ispecific _ *) -> 1 - end - | Lreloadretaddr -> 1 - | Lreturn -> 2 - | Llabel _ -> 0 - | Lbranch _ -> 1 (* b,n *) - | Lcondbranch(Ifloattest(_, _), _) -> 4 (* fcmp/ftest/b/nop *) - | Lcondbranch(_, _) -> 2 (* comb/nop or comclr/b,n *) - | Lcondbranch3(_, _, _) -> 6 (* worst case: three comib/nop or comclr/b,n *) - | Lswitch tbl -> 2 + 2 * Array.length tbl (* blr/nop b/nop *) - | Lsetuptrap _ -> 2 (* bl/nop *) - | Lpushtrap -> 3 (* stws,ma/stw/copy *) - | Lpoptrap -> 1 (* ldws,mb *) - | Lraise -> 4 (* ldw/copy/bv/ldws,mb *) - -(* Estimate the position of all labels in function body - and rewrite long conditional branches with a negative label. *) - -let fixup_cond_branches funbody = - let label_position = - (Hashtbl.create 87 : (label, int) Hashtbl.t) in - let rec estimate_labels pos i = - match i.desc with - Lend -> () - | Llabel lbl -> - Hashtbl.add label_position lbl pos; estimate_labels pos i.next - | _ -> estimate_labels (pos + sizeof_instr i) i.next in - let long_branch currpos lbl = - try - let displ = Hashtbl.find label_position lbl - currpos in - (* Branch offset is stored in 12 bits, giving a range of - -2048 to +2047. Here, we allow 10% error in estimating - the code positions. *) - displ < -1843 || displ > 1842 - with Not_found -> - assert false in - let rec fix_branches pos i = - match i.desc with - Lend -> () - | Lcondbranch(tst, lbl) -> - if long_branch pos lbl then i.desc <- Lcondbranch(tst, -lbl); - fix_branches (pos + sizeof_instr i) i.next - | Lcondbranch3(opt1, opt2, opt3) -> - let fix_opt = function - None -> None - | Some lbl -> Some(if long_branch pos lbl then -lbl else lbl) in - i.desc <- Lcondbranch3(fix_opt opt1, fix_opt opt2, fix_opt opt3); - fix_branches (pos + sizeof_instr i) i.next - | _ -> - fix_branches (pos + sizeof_instr i) i.next in - estimate_labels 0 funbody; - fix_branches 0 funbody - -(* Emission of a function declaration *) - -let fundecl fundecl = - fixup_cond_branches fundecl.fun_body; - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - tailrec_entry_point := new_label(); - stack_offset := 0; - float_constants := []; - define_symbol fundecl.fun_name; - range_check_trap := 0; - let n = frame_size() in - begin match Config.system with - | "hpux" -> - ` .code\n`; - ` .align 4\n`; - ` .export {emit_symbol fundecl.fun_name}, entry, priv_lev=3\n`; - `{emit_symbol fundecl.fun_name}:\n`; - ` .proc\n`; - if !contains_calls then - ` .callinfo frame={emit_int n}, calls, save_rp\n` - else - ` .callinfo frame={emit_int n}, no_calls\n`; - ` .entry\n` - | "linux" | "gnu" -> - ` .text\n`; - ` .align 8\n`; - ` .globl {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n` - | _ -> - assert false - end; - if !contains_calls then - ` stwm %r2, {emit_int n}(%r30)\n` - else if n > 0 then - ` ldo {emit_int n}(%r30), %r30\n`; - `{emit_label !tailrec_entry_point}:\n`; - emit_all fundecl.fun_body; - if !range_check_trap > 0 then begin - `{emit_label !range_check_trap}:\n`; - emit_call "caml_ml_array_bound_error" "%r31"; - ` nop\n` - end; - if Config.system = "hpux"then begin - ` .exit\n`; - ` .procend\n` - end; - emit_float_constants() - -(* Emission of data *) - -let declare_global s = - define_symbol s; - if Config.system = "hpux" - then ` .export {emit_symbol s}, data\n` - else ` .globl {emit_symbol s}\n` - -let emit_item = function - Cglobal_symbol s -> - declare_global s - | Cdefine_symbol s -> - define_symbol s; - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (lbl + 100000)}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .short {emit_int n}\n` - | Cint32 n -> - ` .long {emit_nativeint n}\n` - | Cint n -> - ` .long {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_split_directive ".long" f - | Csymbol_address s -> - use_symbol s; - ` .long {emit_symbol s}\n` - | Clabel_address lbl -> - ` .long {emit_label(lbl + 100000)}\n` - | Cstring s -> - emit_string_directive " .ascii " s - | Cskip n -> - if n > 0 then - if Config.system = "hpux" - then ` .block {emit_int n}\n` - else ` .space {emit_int n}\n` - | Calign n -> - emit_align n - -let data l = - ` .data\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - if Config.system = "hpux" then begin - ` .space $PRIVATE$\n`; - ` .subspa $DATA$,quad=1,align=8,access=31\n`; - ` .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82\n`; - ` .space $TEXT$\n`; - ` .subspa $LIT$,quad=0,align=8,access=44\n`; - ` .subspa $CODE$,quad=0,align=8,access=44,code_only\n`; - ` .import $global$, data\n`; - ` .import $$divI, millicode\n`; - ` .import $$remI, millicode\n` - end; - used_symbols := StringSet.empty; - defined_symbols := StringSet.empty; - called_symbols := StringSet.empty; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - declare_global lbl_begin; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .code\n`; - declare_global lbl_begin; - `{emit_symbol lbl_begin}:\n` - - -let end_assembly() = - ` .code\n`; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - declare_global lbl_end; - `{emit_symbol lbl_end}:\n`; - ` .data\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - declare_global lbl_end; - `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - declare_global lbl; - `{emit_symbol lbl}:\n`; - ` .long {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := []; - emit_imports() diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml deleted file mode 100644 index c0b40adb..00000000 --- a/asmcomp/hppa/proc.ml +++ /dev/null @@ -1,224 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Description of the HP PA-RISC processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Registers available for register allocation *) - -(* Register map: - %r0 always zero - %r1 temporary, target of ADDIL - %r2 return address - %r3 allocation pointer - %r4 allocation limit - %r5 trap pointer - %r6 - %r26 general purpose - %r27 global pointer - %r28 - %r29 general purpose, C function results - %r30 stack pointer - %r31 temporary, used by BLE - - %fr0 - %fr3 float status info - %fr4 - %fr30 general purpose - %fr31 temporary *) - -let int_reg_name = [| - (* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10"; - (* 5-10 *) "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16"; - (* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22"; - (* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26"; - (* 21-22 *) "%r28"; "%r29" -|] - -let float_reg_name = [| - (* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9"; - (* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15"; - (* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21"; - (* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27"; - (* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 23; 27 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 23 Reg.dummy in - for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 28 Reg.dummy in - for i = 0 to 27 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg (Array.sub hard_float_reg 0 27) - (* No need to include the left/right parts of float registers *) - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Instruction selection *) - -let word_addressed = false - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float make_stack - arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int >= last_int then begin - loc.(i) <- phys_reg !int; - decr int - end else begin - ofs := !ofs + size_int; - loc.(i) <- stack_slot (make_stack !ofs) ty - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - ofs := Misc.align (!ofs + size_float) 8; - loc.(i) <- stack_slot (make_stack !ofs) Float - end - done; - (loc, Misc.align !ofs 8) (* Keep stack 8-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -(* Arguments and results: %r26-%r19, %fr4-%fr11. *) - -let loc_arguments arg = - calling_conventions 20 13 100 107 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 20 13 100 107 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 20 13 100 107 not_supported res in loc - -(* Calling C functions: - when all arguments are integers, use %r26 - %r23, - then -52(%r30), -56(%r30), etc. - When some arguments are floats, we handle a couple of cases by hand - and fail otherwise. *) - -let loc_external_arguments arg = - match List.map register_class (Array.to_list arg) with - [1] -> ([| phys_reg 101 |], 56) (* %fr5 *) - | [1; 1] -> ([| phys_reg 101; phys_reg 103 |], 56) (* %fr5, %fr7 *) - | [1; 0] -> ([| phys_reg 101; phys_reg 18 |], 56) (* %fr5, %r24 *) - | [0; 1] -> ([| phys_reg 20; phys_reg 103 |], 56) (* %r26, %fr7 *) - | _ -> - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref 20 in - let ofs = ref 48 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int >= 17 then begin - loc.(i) <- phys_reg (!int); - decr int - end else begin - ofs := !ofs + 4; - loc.(i) <- stack_slot (Outgoing !ofs) ty - end - | Float -> - fatal_error "Proc.external_calling_conventions: cannot call" - done; - (loc, Misc.align !ofs 8) - -let loc_external_results res = - let (loc, ofs) = calling_conventions 21 21 100 100 not_supported res in loc - -let loc_exn_bucket = phys_reg 20 (* %r26 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* %r3 - %r18, %fr12 - %fr21 preserved *) - Array.of_list(List.map phys_reg - [13;14;15;16;17;18;19;20;21;22; - 100;101;102;103;104;105;106;107;118;119;120;121;122;123;124;125;126]) - -let destroyed_by_millicode = (* %r25, %r26, %r28, %r29 -- more? *) - [| phys_reg 19; phys_reg 20; phys_reg 21; phys_reg 22 |] - -let destroyed_by_alloc = [| phys_reg 22 |] (* %r29 *) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> destroyed_by_millicode - | Iop(Ialloc _) -> destroyed_by_alloc - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 16 - | Iintop(Idiv | Imod) -> 19 - | _ -> 23 - -let max_register_pressure = function - Iextcall(_, _) -> [| 16; 19 |] - | Iintop(Idiv | Imod) -> [| 19; 27 |] - | _ -> [| 23; 27 |] - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml deleted file mode 100644 index 54208fcc..00000000 --- a/asmcomp/hppa/reload.ml +++ /dev/null @@ -1,38 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Reloading for the HPPA *) - - -open Cmm -open Arch -open Reg -open Mach -open Proc - -class reload = object (self) - -inherit Reloadgen.reload_generic as super - -method reload_operation op arg res = - match op with - Iintop(Idiv | Imod) - | Iintop_imm((Idiv | Imod), _) -> (arg, res) - | _ -> super#reload_operation op arg res -end - - - -let fundecl f = - (new reload)#fundecl f diff --git a/asmcomp/hppa/scheduling.ml b/asmcomp/hppa/scheduling.ml deleted file mode 100644 index 0cdd0998..00000000 --- a/asmcomp/hppa/scheduling.ml +++ /dev/null @@ -1,59 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Instruction scheduling for the HPPA *) - -open Arch -open Mach - -class scheduler = object (self) - -inherit Schedgen.scheduler_generic - -(* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *) - -method oper_latency = function - Ireload -> 2 - | Iload(_, _) -> 2 - | Iconst_float _ -> 2 (* turned into a load *) - | Iintop Imul -> 2 (* ends up with a load *) - | Iaddf | Isubf | Imulf -> 3 - | Idivf -> 12 - | _ -> 1 - -(* Issue cycles. Rough approximations. *) - -method oper_issue_cycles = function - Iconst_float _ -> 3 - | Iconst_symbol _ -> 2 - | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 - | Ialloc _ -> 5 - | Iintop Imul -> 10 - | Iintop Ilsl -> 3 - | Iintop Ilsr -> 2 - | Iintop Iasr -> 3 - | Iintop(Icomp _) -> 2 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 5 - | Iintop_imm(Icomp _, _) -> 2 - | Iintop_imm(Icheckbound, _) -> 2 - | Ifloatofint -> 4 - | Iintoffloat -> 4 - | _ -> 1 - -end - -let fundecl f = (new scheduler)#schedule_fundecl f diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml deleted file mode 100644 index 74c546b0..00000000 --- a/asmcomp/hppa/selection.ml +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Instruction selection for the HPPA processor *) - -open Misc -open Cmm -open Reg -open Arch -open Proc -open Mach - -let shiftadd = function - 2 -> Ishift1add - | 4 -> Ishift2add - | 8 -> Ishift3add - | _ -> fatal_error "Proc_hppa.shiftadd" - -class selector = object (self) - -inherit Selectgen.selector_generic as super - -method is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) - -method select_addressing = function - Cconst_symbol s -> - (Ibased(s, 0), Ctuple []) - | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> - (Ibased(s, n), Ctuple []) - | Cop(Cadda, [arg; Cconst_int n]) -> - (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) - | arg -> - (Iindexed 0, arg) - -method! select_operation op args = - match (op, args) with - (* Recognize shift-add operations. *) - ((Caddi|Cadda), - [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)])]) -> - (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)])]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - | ((Caddi|Cadda), - [arg2; Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1])]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)]); arg2]) -> - (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)]); arg2]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - | (Caddi, [Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1]); arg2]) -> - (Ispecific(shiftadd mult), [arg1; arg2]) - (* Prevent the recognition of some immediate arithmetic operations *) - (* Cmuli : -> Ilsl if power of 2 - Cdivi, Cmodi : only if power of 2 - Cand, Cor, Cxor : never *) - | (Cmuli, ([arg1; Cconst_int n] as args)) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else (Iintop Imul, args) - | (Cmuli, ([Cconst_int n; arg1] as args)) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else (Iintop Imul, args) - | (Cmuli, args) -> (Iintop Imul, args) - | (Cdivi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | (Cdivi, args) -> (Iintop Idiv, args) - | (Cmodi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | (Cmodi, args) -> (Iintop Imod, args) - | (Cand, args) -> (Iintop Iand, args) - | (Cor, args) -> (Iintop Ior, args) - | (Cxor, args) -> (Iintop Ixor, args) - | _ -> - super#select_operation op args - -(* Deal with register constraints *) - -method! insert_op_debug op dbg rs rd = - match op with - Iintop(Idiv | Imod) -> (* handled via calls to millicode *) - let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *) - and rd' = [|phys_reg 22|] (* %r29 *) in - self#insert_moves rs rs'; - self#insert_debug (Iop op) dbg rs' rd'; - self#insert_moves rd' rd; - rd - | _ -> - super#insert_op_debug op dbg rs rd - -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index 04d673d9..e6fb8b90 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -59,6 +59,10 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = true + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 881a936a..d52b1db6 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -82,6 +82,9 @@ let label_prefix = let emit_label lbl = emit_string label_prefix; emit_int lbl +let emit_data_label lbl = + emit_string label_prefix; emit_string "d"; emit_int lbl + (* Some data directives have different names under Solaris *) @@ -309,9 +312,18 @@ let output_test_zero arg = (* Deallocate the stack frame before a return or tail call *) -let output_epilogue () = +let output_epilogue f = let n = frame_size() - 4 in - if n > 0 then ` addl ${emit_int n}, %esp\n` + if n > 0 then + begin + ` addl ${emit_int n}, %esp\n`; + cfi_adjust_cfa_offset (-n); + f (); + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n + end + else + f () (* Determine if the given register is the top of the floating-point stack *) @@ -415,6 +427,7 @@ let external_symbols_direct = ref StringSet.empty let external_symbols_indirect = ref StringSet.empty let emit_instr fallthrough i = + emit_debug_info i.dbg; match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> @@ -463,14 +476,16 @@ let emit_instr fallthrough i = ` call {emit_symbol s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> - output_epilogue(); + output_epilogue begin fun () -> ` jmp *{emit_reg i.arg.(0)}\n` + end | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin - output_epilogue(); + output_epilogue begin fun () -> ` jmp {emit_symbol s}\n` + end end | Lop(Iextcall(s, alloc)) -> if alloc then begin @@ -496,6 +511,7 @@ let emit_instr fallthrough i = if n < 0 then ` addl ${emit_int(-n)}, %esp\n` else ` subl ${emit_int(n)}, %esp\n`; + cfi_adjust_cfa_offset n; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in @@ -649,6 +665,7 @@ let emit_instr fallthrough i = ` fldl {emit_reg i.arg.(0)}\n`; stack_offset := !stack_offset - 8; ` subl $8, %esp\n`; + cfi_adjust_cfa_offset 8; ` fnstcw 4(%esp)\n`; ` movw 4(%esp), %ax\n`; ` movb $12, %ah\n`; @@ -663,6 +680,7 @@ let emit_instr fallthrough i = end; ` fldcw 4(%esp)\n`; ` addl $8, %esp\n`; + cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` @@ -679,29 +697,36 @@ let emit_instr fallthrough i = match r with {loc = Reg _; typ = Float} -> ` subl $8, %esp\n`; + cfi_adjust_cfa_offset 8; ` fstpl 0(%esp)\n`; stack_offset := !stack_offset + 8 | {loc = Stack sl; typ = Float} -> let ofs = slot_offset sl 1 in ` pushl {emit_int(ofs + 4)}(%esp)\n`; ` pushl {emit_int(ofs + 4)}(%esp)\n`; + cfi_adjust_cfa_offset 8; stack_offset := !stack_offset + 8 | _ -> ` pushl {emit_reg r}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 done | Lop(Ispecific(Ipush_int n)) -> ` pushl ${emit_nativeint n}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_symbol s)) -> ` pushl ${emit_symbol s}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load addr)) -> ` pushl {emit_addressing addr i.arg 0}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load_float addr)) -> ` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; ` pushl {emit_addressing addr i.arg 0}\n`; + cfi_adjust_cfa_offset 8; stack_offset := !stack_offset + 8 | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> if not (is_tos i.arg.(0)) then @@ -719,8 +744,9 @@ let emit_instr fallthrough i = | Lreloadretaddr -> () | Lreturn -> - output_epilogue(); + output_epilogue begin fun () -> ` ret\n` + end | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> @@ -784,11 +810,13 @@ let emit_instr fallthrough i = if trap_frame_size > 8 then ` subl ${emit_int (trap_frame_size - 8)}, %esp\n`; ` pushl {emit_symbol "caml_exception_pointer"}\n`; + cfi_adjust_cfa_offset trap_frame_size; ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; stack_offset := !stack_offset + trap_frame_size | Lpoptrap -> ` popl {emit_symbol "caml_exception_pointer"}\n`; ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; + cfi_adjust_cfa_offset (-trap_frame_size); stack_offset := !stack_offset - trap_frame_size | Lraise -> if !Clflags.debug then begin @@ -897,14 +925,20 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc (); if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in if n > 0 then + begin ` subl ${emit_int n}, %esp\n`; + cfi_adjust_cfa_offset n; + end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); + cfi_endproc (); begin match Config.system with "linux_elf" | "bsd_elf" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; @@ -921,7 +955,7 @@ let emit_item = function | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` + `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -937,7 +971,7 @@ let emit_item = function | Csymbol_address s -> ` .long {emit_symbol s}\n` | Clabel_address lbl -> - ` .long {emit_label (100000 + lbl)}\n` + ` .long {emit_data_label lbl}\n` | Cstring s -> if use_ascii_dir then emit_string_directive " .ascii " s diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 7091b3df..48704ab4 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -71,6 +71,9 @@ let emit_int32 n = emit_printf "0%lxh" n let emit_label lbl = emit_string "L"; emit_int lbl +let emit_data_label lbl = + emit_string "Ld"; emit_int lbl + (* Output an align directive. *) let emit_align n = ` ALIGN {emit_int n}\n` @@ -813,7 +816,7 @@ let emit_item = function add_def_symbol s ; `{emit_symbol s} LABEL DWORD\n` | Cdefine_label lbl -> - `{emit_label (100000 + lbl)} LABEL DWORD\n` + `{emit_data_label lbl} LABEL DWORD\n` | Cint8 n -> ` BYTE {emit_int n}\n` | Cint16 n -> @@ -830,7 +833,7 @@ let emit_item = function add_used_symbol s ; ` DWORD {emit_symbol s}\n` | Clabel_address lbl -> - ` DWORD {emit_label (100000 + lbl)}\n` + ` DWORD {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " BYTE " s | Cskip n -> @@ -881,6 +884,7 @@ let end_assembly() = add_def_symbol lbl_end; ` PUBLIC {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end} LABEL DWORD\n`; + ` DWORD 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index d2e3cdda..10ac59bf 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -20,6 +20,12 @@ open Cmm open Reg open Mach +(* Which asm conventions to use *) +let masm = + match Config.ccomp_type with + | "msvc" -> true + | _ -> false + (* Registers available for register allocation *) (* Register map: @@ -34,10 +40,16 @@ open Mach tos 100 top of floating-point stack. *) let int_reg_name = - [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |] + if masm then + [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |] + else + [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |] let float_reg_name = - [| "%tos" |] + if masm then + [| "tos" |] + else + [| "%tos" |] let num_register_classes = 2 @@ -181,8 +193,13 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + if masm then + Ccomp.command (Config.asm ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ + (if !Clflags.verbose then "" else ">NUL")) + else + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml deleted file mode 100644 index 5e617ff1..00000000 --- a/asmcomp/i386/proc_nt.ml +++ /dev/null @@ -1,186 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Description of the Intel 386 processor, for Windows NT *) - -open Misc -open Arch -open Cmm -open Reg -open Mach - -(* Registers available for register allocation *) - -(* Register map: - eax 0 eax - edi: function arguments and results - ebx 1 eax: C function results - ecx 2 ebx, esi, edi, ebp: preserved by C - edx 3 - esi 4 - edi 5 - ebp 6 - - tos 100 top of floating-point stack. *) - -let int_reg_name = - [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |] - -let float_reg_name = - [| "tos" |] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 7; 0 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -(* There is little scheduling, and some operations are more compact - when their argument is %eax. *) - -let rotate_registers = false - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 7 Reg.dummy in - for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = [| Reg.at_location Float (Reg 100) |] - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let eax = phys_reg 0 -let ecx = phys_reg 2 -let edx = phys_reg 3 -let tos = phys_reg 100 - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Instruction selection *) - -let word_addressed = false - -(* Calling conventions *) - -(* To supplement the processor's meagre supply of registers, we also - use some global memory locations to pass arguments beyond the 6th. - These globals are denoted by Incoming and Outgoing stack locations - with negative offsets, starting at -64. - Unlike arguments passed on stack, arguments passed in globals - do not prevent tail-call elimination. The caller stores arguments - in these globals immediately before the call, and the first thing the - callee does is copy them to registers or stack locations. - Neither GC nor thread context switches can occur between these two - times. *) - -let calling_conventions first_int last_int first_float last_float make_stack - arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref (-64) in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, max 0 !ofs) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 0 5 100 99 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc -let extcall_use_push = true -let loc_external_arguments arg = - fatal_error "Proc.loc_external_arguments" -let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc - -let loc_exn_bucket = eax - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) - Array.of_list(List.map phys_reg [0;2;3]) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] - | Iop(Iintop_imm(Imod, _)) -> [| eax |] - | Iop(Ialloc _) -> [| eax |] - | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] - | Iop(Iintoffloat) -> [| eax |] - | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure op = 4 - -let max_register_pressure = function - Iextcall(_, _) -> [| 4; max_int |] - | Iintop(Idiv | Imod) -> [| 5; max_int |] - | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | - Iintoffloat -> [| 6; max_int |] - | _ -> [|7; max_int |] - -(* Layout of the stack frame *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ - (if !Clflags.verbose then "" else ">NUL")) diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 539d45da..66ad6a14 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/i386/scheduling.ml b/asmcomp/i386/scheduling.ml index 6f018cc8..cbfaa211 100644 --- a/asmcomp/i386/scheduling.ml +++ b/asmcomp/i386/scheduling.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 5a8720fb..38c7a1d7 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -168,7 +168,7 @@ method! is_simple_expr e = | _ -> super#is_simple_expr e -method select_addressing exp = +method select_addressing chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) @@ -200,7 +200,7 @@ method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> - begin match self#select_addressing (Cop(op, args)) with + begin match self#select_addressing Word (Cop(op, args)) with (Iindexed d, _) -> super#select_operation op args | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) @@ -233,7 +233,7 @@ method! select_operation op args = begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] when loc = loc' -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> super#select_operation op args @@ -250,11 +250,11 @@ method! select_operation op args = method select_floatarith regular_op reversed_op mem_op mem_rev_op args = match args with [arg1; Cop(Cload chunk, [loc2])] -> - let (addr, arg2) = self#select_addressing loc2 in + let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)), [arg1; arg2]) | [Cop(Cload chunk, [loc1]); arg2] -> - let (addr, arg1) = self#select_addressing loc1 in + let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)), [arg2; arg1]) | [arg1; arg2] -> @@ -282,9 +282,6 @@ method! insert_op_debug op dbg rs rd = with Use_default -> super#insert_op_debug op dbg rs rd -method! insert_op op rs rd = - self#insert_op_debug op Debuginfo.none rs rd - (* Selection of push instructions for external calls *) method select_push exp = @@ -295,10 +292,10 @@ method select_push exp = | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple []) | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) | Cop(Cload Word, [loc]) -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ipush_load addr), arg) | Cop(Cload Double_u, [loc]) -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Double_u loc in (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) diff --git a/asmcomp/ia64/arch.ml b/asmcomp/ia64/arch.ml deleted file mode 100644 index 77dddaca..00000000 --- a/asmcomp/ia64/arch.ml +++ /dev/null @@ -1,88 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Specific operations for the IA64 processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Addressing modes -- only one! (register with no displacement) *) - -type addressing_mode = Iindexed - -(* Specific operations *) - -type specific_operation = - Iadd1 (* x + y + 1 or x + x + 1 *) - | Isub1 (* x - y - 1 *) - | Ishladd of int (* x << N + y *) - | Isignextend of int (* truncate 64-bit int to 8N-bit int *) - | Imultaddf (* x *. y +. z *) - | Imultsubf (* x *. y -. z *) - | Isubmultf (* z -. x *. y *) - | Istoreincr of int (* store y at x; x <- x + N *) - | Iinitbarrier (* end of object initialization *) - -(* Sizes, endianness *) - -let big_endian = false - -let size_addr = 8 -let size_int = 8 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed - -let offset_addressing addr delta = assert false - -let num_args_addressing = function Iindexed -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - printreg ppf arg.(0) - -let print_specific_operation printreg op ppf arg = - match op with - | Iadd1 -> - if Array.length arg >= 2 then - fprintf ppf "%a + %a + 1 " printreg arg.(0) printreg arg.(1) - else - fprintf ppf "%a << 1 + 1 " printreg arg.(0) - | Isub1 -> - fprintf ppf "%a - %a - 1 " printreg arg.(0) printreg arg.(1) - | Ishladd n -> - fprintf ppf "%a << %d + %a" printreg arg.(0) n printreg arg.(1) - | Isignextend n -> - fprintf ppf "truncate%d %a" (n * 8) printreg arg.(0) - | Imultaddf -> - fprintf ppf "%a * %a + %a" - printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Imultsubf -> - fprintf ppf "%a * %a - %a" - printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Isubmultf -> - fprintf ppf "%a - %a * %a" - printreg arg.(2) printreg arg.(0) printreg arg.(1) - | Istoreincr n -> - fprintf ppf "[%a] := %a; %a += %d" - printreg arg.(0) printreg arg.(1) printreg arg.(0) n - | Iinitbarrier -> - fprintf ppf "initbarrier" diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp deleted file mode 100644 index 3d8eeb97..00000000 --- a/asmcomp/ia64/emit.mlp +++ /dev/null @@ -1,1327 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Emission of IA64 assembly code *) - -open Location -open Printf -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(************** Part 1: assembly-level scheduler *******************) - -(* Representation of resources accessed or produced by instructions *) - -type resource = string - (* A resource is either: - - a register name - - "stkN" for a stack location - - "heap" for the Caml heap - - "chkN" for the result of a checkbound instruction *) - -let is_memory_resource rsrc = - String.length rsrc >= 4 && - begin match String.sub rsrc 0 3 with - "stk" -> true - | "hea" -> true - | "chk" -> true - | _ -> false - end - -let is_mutable_resource rsrc = - rsrc <> "r0" && rsrc <> "p0" - -(* Description of instructions *) - -type instruction_kind = - KA (* A type instruction (int or mem unit) *) - | KB (* B type instruction (branch unit) *) - | KI (* I type instruction (int unit *) - | KF (* F type instruction (FP unit) *) - | KM (* M type instruction (mem unit) *) - | KB_exc (* B type instruction, exceptional condition, - can be moved around *) - -type instruction_format = - F_i (* op imm *) - | F_i_pred (* (pred) op imm *) - | F_ir_rr (* op p1,p2 = imm, r *) - | F_ir_r (* op r = imm, r *) - | F_ir_r_pred (* (pred) op r = imm, r *) - | F_ld (* op r = [r] *) - | F_ld_post (* op r = [r], imm *) - | F_r (* op r *) - | F_i_r (* op r = imm *) - | F_i_r_pred (* (pred) op r = imm *) - | F_ri_rr (* op p1,p2 = imm, r *) - | F_ri_r (* op r = imm, r *) - | F_r_r (* op r = r *) - | F_r_r_pred (* (pred) op r = r *) - | F_rr_rr (* op p1,p2 = r1, r2 *) - | F_r_rir (* op r = r1, imm, r2 *) - | F_rr_r (* op r = r1, r2 *) - | F_rr_r_pred (* (pred) op r = r1, r2 *) - | F_rri_r (* op r = r1, r2, imm *) - | F_rrr_r (* op r = r1, r2, r3 *) - | F_rrr_r_pred (* (pred) op r = r1, r2, r3 *) - | F_st (* op [r] = r *) - | F_st_post (* op [r] = r, imm *) - -type instruction_descr = - { opcode: string; (* actual opcode *) - latency: int; (* latency in cycles *) - kind: instruction_kind; (* kind of instruction *) - format: instruction_format } (* how to generate asm for it *) - -let instruction_table = create_hashtable 73 [ - "add", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r}; - "add1", {opcode = "add"; latency = 1; kind = KA; format = F_rri_r}; - "addcond", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r_pred}; - "addi", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r}; - "addicond", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r_pred}; - "and", {opcode = "and"; latency = 1; kind = KA; format = F_rr_r}; - "andi", {opcode = "and"; latency = 1; kind = KA; format = F_ir_r}; - "br", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_i}; - "brret", {opcode = "br.ret.sptk"; latency = 1; kind = KB; format = F_r}; - "brcall", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_i_r}; - "brcallcond", {opcode = "br.call.spnt.many"; latency = 1; kind = KB; format = F_i_r_pred}; - "brcallcondexc", {opcode = "br.call.spnt.many"; latency = 1; kind = KB_exc; format = F_i_r_pred}; - "brcallind", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_r_r}; - "brcond", {opcode = "br.dpnt.many"; latency = 1; kind = KB; format = F_i_pred}; - "brind", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_r}; - "cmp.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_rr_rr}; - "cmp.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_rr_rr}; - "cmpi.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpi.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_ir_rr}; - "cmpp.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_rr_rr}; - "cmpp.ne.and", {opcode = "cmp.ne.and"; latency = 1; kind = KA; format = F_rr_rr}; - "cmppi.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_ir_rr}; - "cmppi.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_ir_rr}; - "extr.u", {opcode = "extr.u"; latency = 1; kind = KI; format = F_ri_r}; - "fabs", {opcode = "fabs"; latency = 1; kind = KF; format = F_r_r}; - "fadd.d", {opcode = "fadd.d"; latency = 5; kind = KF; format = F_rr_r}; - "fcmp.eq", {opcode = "fcmp.eq"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.ge", {opcode = "fcmp.ge"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.gt", {opcode = "fcmp.gt"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.le", {opcode = "fcmp.le"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.lt", {opcode = "fcmp.lt"; latency = 1; kind = KF; format = F_rr_rr}; - "fcmp.neq", {opcode = "fcmp.neq"; latency = 1; kind = KF; format = F_rr_rr}; - "fcvt.fx.trunc", {opcode = "fcvt.fx.trunc"; latency = 7; kind = KF; format = F_r_r}; - "fcvt.xf", {opcode = "fcvt.xf"; latency = 5; kind = KF; format = F_r_r}; - "fma.d", {opcode = "fma.d"; latency = 5; kind = KF; format = F_rrr_r}; - "fmacond", {opcode = "fma.d.s0"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fmas1cond", {opcode = "fma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fmads1cond", {opcode = "fma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fmpy.d", {opcode = "fmpy.d"; latency = 5; kind = KF; format = F_rr_r}; - "fms.d", {opcode = "fms.d"; latency = 5; kind = KF; format = F_rrr_r}; - "fneg", {opcode = "fneg"; latency = 1; kind = KF; format = F_r_r}; - "fnma.d", {opcode = "fnma.d"; latency = 5; kind = KF; format = F_rrr_r}; - "fnmas1cond", {opcode = "fnma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fnmads1cond", {opcode = "fnma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred}; - "fnorm.d", {opcode = "fnorm.d"; latency = 5; kind = KF; format = F_r_r}; - "frcpa", {opcode = "frcpa.s0"; latency = 5; kind = KF; format = F_rr_rr}; - "fsub.d", {opcode = "fsub.d"; latency = 5; kind = KF; format = F_rr_r}; - "getf.sig", {opcode = "getf.sig"; latency = 2; kind = KM; format = F_r_r}; - "ld1", {opcode = "ld1"; latency = 2; kind = KM; format = F_ld}; - "ld2", {opcode = "ld2"; latency = 2; kind = KM; format = F_ld}; - "ld4", {opcode = "ld4"; latency = 2; kind = KM; format = F_ld}; - "ld8", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld}; - "ld8+", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld_post}; - "ldfd", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld}; - "ldfd+", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld_post}; - "ldfs", {opcode = "ldfs"; latency = 9; kind = KM; format = F_ld}; - "mov", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r}; - "movcond", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r_pred}; - "movtb", {opcode = "mov"; latency = 9; kind = KI; format = F_r_r}; - "movfb", {opcode = "mov"; latency = 2; kind = KI; format = F_r_r}; - "movi", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r}; - "movicond", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r_pred}; - "movil", {opcode = "movl"; latency = 1; kind = KI; format = F_i_r}; - "movpr", {opcode = "mov"; latency = 1; kind = KI; format = F_ri_r}; - "or", {opcode = "or"; latency = 1; kind = KA; format = F_rr_r}; - "ori", {opcode = "or"; latency = 1; kind = KA; format = F_ir_r}; - "setf.d", {opcode = "setf.d"; latency = 8; kind = KM; format = F_r_r}; - "setf.sig", {opcode = "setf.sig"; latency = 8; kind = KM; format = F_r_r}; - "shl", {opcode = "shl"; latency = 2; kind = KI; format = F_rr_r}; - "shladd", {opcode = "shladd"; latency = 1; kind = KA; format = F_r_rir}; - "shli", {opcode = "shl"; latency = 1; kind = KI; format = F_ri_r}; - "shr", {opcode = "shr"; latency = 2; kind = KI; format = F_rr_r}; - "shri", {opcode = "shr"; latency = 1; kind = KI; format = F_ri_r}; - "shru", {opcode = "shr.u"; latency = 2; kind = KI; format = F_rr_r}; - "shrui", {opcode = "shr.u"; latency = 1; kind = KI; format = F_ri_r}; - "st1", {opcode = "st1"; latency = 0; kind = KM; format = F_st}; - "st2", {opcode = "st2"; latency = 0; kind = KM; format = F_st}; - "st4", {opcode = "st4"; latency = 0; kind = KM; format = F_st}; - "st8", {opcode = "st8"; latency = 0; kind = KM; format = F_st}; - "st8+", {opcode = "st8"; latency = 1; kind = KM; format = F_st_post}; - "stfd", {opcode = "stfd"; latency = 0; kind = KM; format = F_st}; - "stfd+", {opcode = "stfd"; latency = 1; kind = KM; format = F_st_post}; - "stfs", {opcode = "stfs"; latency = 0; kind = KM; format = F_st}; - "sub", {opcode = "sub"; latency = 1; kind = KA; format = F_rr_r}; - "sub1", {opcode = "sub"; latency = 1; kind = KA; format = F_rri_r}; - "subi", {opcode = "sub"; latency = 1; kind = KA; format = F_ir_r}; - "sxt1", {opcode = "sxt1"; latency = 1; kind = KI; format = F_r_r}; - "sxt2", {opcode = "sxt2"; latency = 1; kind = KI; format = F_r_r}; - "sxt4", {opcode = "sxt4"; latency = 1; kind = KI; format = F_r_r}; - "tbit.nz", {opcode = "tbit.nz"; latency = 0; kind = KI; format = F_ri_rr}; - "tbit.z", {opcode = "tbit.z"; latency = 0; kind = KI; format = F_ri_rr}; - "xmpy.l", {opcode = "xmpy.l"; latency = 7; kind = KF; format = F_rr_r}; - "xor", {opcode = "xor"; latency = 1; kind = KA; format = F_rr_r}; - "xori", {opcode = "xor"; latency = 1; kind = KA; format = F_ir_r}; - "#initbarrier", {opcode = "# init barrier"; latency = 0; kind = KI; format = F_i}; -] - -(* Nodes of the code DAG. Each node represents one instruction to be - emitted. *) - -type code_dag_node = - { instr: instruction_descr; (* the instruction *) - imm: string; (* its immediate argument, if any *) - iarg: resource array; (* arguments *) - ires: resource array; (* results *) - delay: int; (* how many cycles before result is available *) - mutable sons: (code_dag_node * int) list; - (* nodes that depend on this node *) - mutable date: int; (* start date *) - mutable length: int; (* length of longest path to result *) - mutable ancestors: int; (* number of ancestors *) - mutable emitted_ancestors: int } (* number of emitted ancestors *) - -(* The code dag itself is represented by two tables from resources to nodes: - - "results" maps resources to the instructions that produced them; - - "uses" maps resources to the instructions that use them. *) - -let code_results = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t) -let code_uses = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t) - -let clear_code_dag () = - Hashtbl.clear code_results; - Hashtbl.clear code_uses - -(* The ready queue: a list of nodes that can be computed immediately - (all arguments are available), kept sorted by decreasing length to results. - - The in progress queue: a list of nodes whose arguments are being computed, - and thus can be computed at a later date, kept sorted by increasing - availability date - - The branch list: a list of all branch instructions (to be emitted last) *) - -let ready_queue = ref ([] : code_dag_node list) -let in_progress_queue = ref ([] : code_dag_node list) -let branch_list = ref ([] : code_dag_node list) (* built in reverse order *) - -let clear_queues () = - ready_queue := []; in_progress_queue := []; branch_list := [] - -let rec insert_queue prio node = function - [] -> [node] - | hd :: tl as queue -> - if prio node hd then node :: queue else hd :: insert_queue prio node tl - -let length_prio n1 n2 = n1.length > n2.length -let date_prio n1 n2 = n1.date < n2.date - -let add_ready node = - ready_queue := insert_queue length_prio node !ready_queue -let add_in_progress node = - in_progress_queue := insert_queue date_prio node !in_progress_queue -let add_branch node = - branch_list := node :: !branch_list - -(* Add an edge to the code DAG *) - -let add_edge ancestor son delay = - ancestor.sons <- (son, delay) :: ancestor.sons; - son.ancestors <- son.ancestors + 1 - -let add_edge_after son ancestor = add_edge ancestor son 0 - -(* Add an instruction to the code DAG *) - -let insimm opc arg imm res = - let instr = - try - Hashtbl.find instruction_table opc - with Not_found -> - fatal_error ("Unknown instruction " ^ opc) in - let node = - { instr = instr; - imm = imm; - iarg = arg; - ires = res; - delay = instr.latency; - sons = []; (* to be filled later *) - date = 0; (* to be adjusted later *) - length = -1; (* to be computed later *) - ancestors = 0; (* ditto *) - emitted_ancestors = 0 } in (* ditto *) - (* RAW dependencies: add edges from all instrs that define one of the - resources used *) - for i = 0 to Array.length arg - 1 do - try - let rsrc = arg.(i) in - if is_mutable_resource rsrc then begin - let anc = Hashtbl.find code_results rsrc in - let delay = if is_memory_resource rsrc then 0 else anc.delay in - (* Memory accesses are ordered by the hardware, so we can emit - a memop 1, then a dependent memop 2 in the same cycle *) - add_edge anc node delay - end - with Not_found -> - () - done; - (* WAR dependencies: add edges from all instrs that use one of the - resources defined by this instruction - WAW dependencies: add edges from all instrs that define one of the - resources defined by this instruction *) - for i = 0 to Array.length res - 1 do - let rsrc = res.(i) in - if is_mutable_resource rsrc then begin - (* WAR *) - let anc = Hashtbl.find_all code_uses res.(i) in - List.iter (add_edge_after node) anc; - (* WAW *) - try - let anc = Hashtbl.find code_results rsrc in - let delay = if is_memory_resource rsrc then 0 else 1 in - add_edge anc node delay - with Not_found -> - () - end - done; - (* Remember the results and uses of this instruction *) - for i = 0 to Array.length res - 1 do - Hashtbl.add code_results res.(i) node - done; - for i = 0 to Array.length arg - 1 do - Hashtbl.add code_uses arg.(i) node - done; - (* Insert in appropriate queue *) - if node.instr.kind = KB - then add_branch node - else if node.ancestors = 0 then add_ready node - -let insert opc arg res = - insimm opc arg "" res - -(* Compute length of longest path to a result. *) - -let rec longest_path node = - if node.length < 0 then begin - node.length <- - List.fold_left - (fun len (son, delay) -> max len (longest_path son + delay)) - 0 node.sons - end; - node.length - -(* Emit the assembly code for a node *) - -let emit_r = emit_string - -let emit_instr node = - let opc = node.instr.opcode - and a = node.iarg - and r = node.ires - and imm = node.imm in - match node.instr.format with - F_i -> - ` {emit_string opc} {emit_string imm}\n` - | F_i_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_string imm}\n` - | F_ir_rr -> - ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_string imm}, {emit_r a.(0)}\n` - | F_ir_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_string imm}, {emit_r a.(0)}\n` - | F_ir_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_string imm}, {emit_r a.(1)}\n` - | F_ld -> - ` {emit_string opc} {emit_r r.(0)} = [{emit_r a.(0)}]\n` - | F_ld_post -> - ` {emit_string opc} {emit_r r.(0)} = [{emit_r a.(0)}], {emit_string imm}\n` - | F_r -> - ` {emit_string opc} {emit_r a.(0)}\n` - | F_i_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_string imm}\n` - | F_i_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_string imm}\n` - | F_ri_rr -> - ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_string imm}\n` - | F_ri_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}\n` - | F_r_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}\n` - | F_r_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}\n` - | F_rr_rr -> - ` {emit_string opc} {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_r a.(1)}\n` - | F_r_rir -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}, {emit_r a.(1)}\n` - | F_rr_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}\n` - | F_rr_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}\n` - | F_rri_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_string imm}\n` - | F_rrr_r -> - ` {emit_string opc} {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_r a.(2)}\n` - | F_rrr_r_pred -> - ` ({emit_r a.(0)}) {emit_string opc} {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}, {emit_r a.(3)}\n` - | F_st -> - ` {emit_string opc} [{emit_r a.(0)}] = {emit_r a.(1)}\n` - | F_st_post -> - ` {emit_string opc} [{emit_r a.(0)}] = {emit_r a.(1)}, {emit_string imm}\n` - -(* Little state machine reflecting how many instructions the chip can - issue in one cycle. We roughly follow the Itanium model: - 2 int units, 2 mem units, 2 FP units, and 3 branch units, - with a maximum of 6 instructions dispatched per clock cycle. *) - -let num_A = ref 0 -let num_I = ref 0 -let num_M = ref 0 -let num_F = ref 0 -let num_B = ref 0 - -let reset_issue () = - num_A := 0; num_I := 0; num_M := 0; num_F := 0; num_B := 0 - -let can_issue instr = - if !num_A + !num_I + !num_M + !num_F + !num_B >= 6 then false else begin - match instr.kind with - KA -> - if !num_A + !num_I + !num_M < 4 - then (incr num_A; true) - else false - | KF -> - if !num_F < 2 then (incr num_F; true) else false - | KI -> - if !num_I < 2 && !num_A + !num_I + !num_M < 4 - then (incr num_I; true) else false - | KM -> - if !num_M < 2 && !num_A + !num_I + !num_M < 4 - then (incr num_M; true) else false - | _ (* KB | KB_exc *) -> - if !num_B < 3 then (incr num_B; true) else false - end - -(* Emit one node, updating the completion date and number of ancestors - emitted for all nodes that depend on this node. Enter the nodes - that are no longer waiting on anything (all ancestors emitted) - in the ready queue or in the in_progress queue, depending on - latency. *) - -let emit_node date node = - begin try - (*`# Date: {emit_int date}; distance: {emit_int node.length}\n`;*) - emit_instr node - with x -> - fatal_error ("Error while emitting " ^ node.instr.opcode) - end; - List.iter - (fun (son, delay) -> - let completion_date = date + delay in - if son.date < completion_date then son.date <- completion_date; - son.emitted_ancestors <- son.emitted_ancestors + 1; - if son.emitted_ancestors = son.ancestors && son.instr.kind <> KB then - begin - (*`# {emit_string son.instr.opcode} will be ready at {emit_int son.date}\n`;*) - if son.date = date then add_ready son else add_in_progress son - end) - node.sons - -(* Emit all ready nodes that we can emit given the architectural - constraints. *) - -let rec emit_ready_nodes filter date = - match !ready_queue with - [] -> [] - | node :: rem -> - ready_queue := rem; - if filter node && can_issue node.instr then begin - emit_node date node; - emit_ready_nodes filter date - end else - node :: emit_ready_nodes filter date - -let filter_MF node = - match node.instr.kind with KM -> true | KF -> true | _ -> false -let filter_non_MF node = - not(filter_MF node) - -(* Add all instructions with date <= d to the ready queue, and remove them *) - -let rec extract_ready d = function - [] -> [] - | node :: rem as queue -> - if node.date <= d then (add_ready node; extract_ready d rem) else queue - -(* Say if a branch is ready to be emitted now *) - -let branch_is_ready date br = - br.emitted_ancestors = br.ancestors && br.date <= date - -(* Schedule the basic block, emitting all of its instructions *) - -let rec reschedule date = - match (!ready_queue, !in_progress_queue) with - ([], []) -> - (* We're done with the regular instructions; finish with the branches *) - begin match !branch_list with - [] -> () - | br -> List.iter emit_instr br; emit_string " ;;\n" - end - | ([], node :: _) -> - (* Advance to the time node.date, extracting from in_progress_queue - all instructions ready at that time and adding them to the - ready queue *) - in_progress_queue := extract_ready node.date !in_progress_queue; - (* Try again *) - reschedule node.date - | (_, _) -> - ` # time {emit_int date}\n`; - (* Emit and remove as many ready instructions as we can *) - (* Give priority to M and F instructions *) - reset_issue(); - ready_queue := emit_ready_nodes filter_MF date; - ready_queue := emit_ready_nodes filter_non_MF date; - (* Special hack: if the only remaining instructions are branches - and they are all ready now, emit them in the current - group of instructions *) - if !ready_queue = [] - && !in_progress_queue = [] - && List.for_all (branch_is_ready date) !branch_list - then begin - List.iter emit_instr !branch_list; - branch_list := [] - end; - (* Emit a stop to pause the processor *) - emit_string " ;;\n"; - (* Advance to the time date + 1, extracting from in_progress_queue - all instructions ready at that time and adding them to the - ready queue *) - in_progress_queue := extract_ready (date + 1) !in_progress_queue; - (* Try again *) - reschedule (date + 1) - -(* Emit the code for the current basic block *) - -let end_basic_block () = - (* Compute critical paths and rebuild ready queue sorted by - decreasing criticality *) - let r = !ready_queue in - ready_queue := []; - let max_length = - List.fold_left (fun len node -> max len (longest_path node)) 0 r in - List.iter add_ready r; - branch_list := List.rev !branch_list; - (* Emit the instructions by traversing the code DAG *) - reschedule 0; - if max_length > 0 then ` # basic block length {emit_int max_length}\n`; - clear_code_dag (); - clear_queues () - -(************** Part 2: the code emitter *******************) - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Translate or output a label *) - -let label lbl = sprintf ".L%d" lbl - -let emit_label lbl = emit_string ".L"; emit_int lbl - -(* Translate or output a symbol *) - -let symbol s = - let b = Buffer.create (String.length s + 1) in - for i = 0 to String.length s - 1 do - let c = s.[i] in - match c with - 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> - Buffer.add_char b c - | _ -> - Buffer.add_string b (sprintf "$%02x" (Char.code c)) - done; - Buffer.add_char b '#'; - Buffer.contents b - -let emit_symbol s = Emitaux.emit_symbol '$' s - -(* Translate a pseudo-register *) - -let reg r = - match r.loc with Reg r -> register_name r | _ -> assert false - -let regs r = - Array.map reg r - -(* Output a pseudo-register *) - -let emit_reg r = - match r.loc with - Reg r -> emit_string (register_name r) - | _ -> fatal_error "Emit_ia64.emit_reg" - -(* Translate a float as a 64-bit integer *) - -let float_bits f = - let b = Buffer.create 18 in - let bytes = (Obj.magic f : string) in - Buffer.add_string b "0x"; - for i = 7 downto 0 do (* little-endian *) - Buffer.add_string b - (sprintf "%02x" (Char.code (String.unsafe_get bytes i))) - done; - Buffer.contents b - -(* Translate an "ltoffset" reference to a global *) - -let ltoffset s = sprintf "@ltoff(%s)" (symbol s) -let ltoffset_fptr s = sprintf "@ltoff(@fptr(%s))" (symbol s) - -(* Layout of the stack frame. - All stack offsets are shifted by 16 to preserve the scratch area at - bottom of stack. *) - -let stack_offset = ref 0 - -let frame_size () = - let size = - !stack_offset + - 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + - (if !contains_calls then 8 else 0) in - Misc.align size 16 - -let slot_offset loc cl = - match loc with - Incoming n -> frame_size() + n + 16 - | Local n -> - if cl = 0 - then !stack_offset + n * 8 + 16 - else !stack_offset + (num_stack_slots.(0) + n) * 8 + 16 - | Outgoing n -> n + 16 - -let slot_offset_reg r = - match r.loc with - Stack l -> slot_offset l (register_class r) - | _ -> assert false - -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((r lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - lbl - -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:` - -let emit_frame fd = - ` data8 {emit_label fd.fd_lbl}\n`; - ` data2 {emit_int fd.fd_frame_size}\n`; - ` data2 {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` data2 {emit_int n}\n`) - fd.fd_live_offset; - ` .align 8\n` - -(* Names of various instructions *) - -let name_for_int_operation = function - Iadd -> "add" - | Isub -> "sub" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "shl" - | Ilsr -> "shru" - | Iasr -> "shr" - | _ -> Misc.fatal_error "Emit.name_for_int_operation" - -let name_for_float_operation = function - Inegf -> "fneg" - | Iabsf -> "fabs" - | Iaddf -> "fadd.d" - | Isubf -> "fsub.d" - | Imulf -> "fmpy.d" - | _ -> Misc.fatal_error "Emit.name_for_float_operation" - -let name_for_specific_operation = function - Imultaddf -> "fma.d" - | Imultsubf -> "fms.d" - | Isubmultf -> "fnma.d" - | _ -> Misc.fatal_error "Emit.name_for_specific_operation" - -let name_for_int_comparison = function - Isigned Ceq -> "eq" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "gt" - | Isigned Clt -> "lt" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "leu" | Iunsigned Cgt -> "gtu" - | Iunsigned Clt -> "ltu" | Iunsigned Cge -> "geu" - -let name_for_swapped_int_comparison = function - Isigned Ceq -> "eq" | Isigned Cne -> "ne" - | Isigned Cle -> "ge" | Isigned Cgt -> "lt" - | Isigned Clt -> "gt" | Isigned Cge -> "le" - | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "geu" | Iunsigned Cgt -> "ltu" - | Iunsigned Clt -> "gtu" | Iunsigned Cge -> "leu" - -let name_for_float_comparison cmp = - match cmp with - Ceq -> "eq" | Cne -> "neq" - | Cle -> "le" | Cgt -> "gt" - | Clt -> "lt" | Cge -> "ge" - -(* Immediate range for addl (move) and adds (general add) instructions *) - -let is_immediate_addl n = n >= -0x200000 && n < 0x200000 -let is_immediate_addl_nat n = - n >= Nativeint.of_int (-0x200000) && n < Nativeint.of_int 0x200000 -let is_immediate_adds n = n >= -0x2000 && n < 0x2000 - -(* Return the positions of all "1" bits in the given integer, - most significant bits first *) - -let ones_pos n = - let rec ones p accu = - if p >= 63 - then accu - else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in - ones 0 [] - -(* Generate temporary registers *) - -let temp_generator temporaries = - let counter = ref 0 in - fun () -> - let r = temporaries.(!counter) in - incr counter; - if !counter >= Array.length temporaries then counter := 0; - r - -let new_temp_reg = - temp_generator [| "r2"; "r3"; "r14"; "r15" |] -let new_temp_float = - temp_generator [| "f64"; "f65"; "f66"; "f67"; - "f68"; "f69"; "f70"; "f71" |] -let new_pred = - temp_generator [| "p2"; "p3"; "p4"; "p5" |] - -(* Output the assembly code for an instruction *) - -(* Name of current function *) -let function_name = ref "" -(* Entry point for tail recursive calls *) -let tailrec_entry_point = ref 0 - -let emit_instr i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src.loc, dst.loc) with - (Reg _, Reg _) -> - insert "mov" (regs i.arg) (regs i.res) - | (Reg _, Stack _) -> - let offset = string_of_int (slot_offset_reg dst) in - let r = new_temp_reg() in - insimm "addi" [| "sp" |] offset [| r |]; - insert (if i.res.(0).typ = Float then "stfd" else "st8") - [| r; reg src |] [| "stk" ^ offset |] - | (Stack _, Reg _) -> - let offset = string_of_int (slot_offset_reg src) in - let r = new_temp_reg() in - insimm "addi" [| "sp" |] offset [| r |]; - insert (if i.arg.(0).typ = Float then "ldfd" else "ld8") - [| r; "stk" ^ offset |] (regs i.res) - | (_, _) -> - assert false - end - | Lop(Iconst_int n) -> - let instr = - if is_immediate_addl_nat n then "movi" else "movil" in - insimm instr [||] (Nativeint.to_string n) (regs i.res) - | Lop(Iconst_float s) -> - let f = float_of_string s in - begin match Int64.bits_of_float f with - | 0x0000_0000_0000_0000L -> (* +0.0 *) - insert "mov" [| "f0" |] (regs i.res) - | 0x3FF0_0000_0000_0000L -> (* 1.0 *) - insert "mov" [| "f1" |] (regs i.res) - | _ -> - let tmp = new_temp_reg() in - insimm "movil" [||] (float_bits f) [| tmp |]; - insert "setf.d" [| tmp |] (regs i.res) - end - | Lop(Iconst_symbol s) -> - insimm "addi" [| "gp" |] (ltoffset s) (regs i.res); - insert "ld8" (regs i.res) (regs i.res) - | Lop(Icall_ind) -> - insert "movtb" (regs i.arg) [| "b0" |]; - insert "brcallind" [| "b0" |] [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n` - | Lop(Icall_imm s) -> - insimm "brcall" [||] (symbol s) [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n` - | Lop(Itailcall_ind) -> - let n = frame_size() in - insert "movtb" (regs i.arg) [| "b6" |]; - if !contains_calls then begin - let tmp = new_temp_reg() in - insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |]; - insert "ld8" [| tmp |] [| tmp |]; - insert "mov" [| tmp |] [| "b0" |] - end; - if n > 0 then - insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; - insert "brind" [| "b6" |] [||]; - end_basic_block() - | Lop(Itailcall_imm s) -> - if s = !function_name then begin - insimm "br" [||] (label !tailrec_entry_point) [||] - end else begin - let n = frame_size() in - if !contains_calls then begin - let tmp = new_temp_reg() in - insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |]; - insert "ld8" [| tmp |] [| tmp |]; - insert "mov" [| tmp |] [| "b0" |] - end; - if n > 0 then - insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; - insimm "br" [||] (symbol s) [||] - end; - end_basic_block() - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - let tmp = new_temp_reg() in - insimm "addi" [| "gp" |] (ltoffset_fptr s) [| tmp |]; - insert "ld8" [| tmp |] [| "r2" |]; - insimm "brcall" [||] "caml_c_call#" [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n` - end else begin - insert "mov" [| "gp" |] [| "r7" |]; - insimm "brcall" [||] (symbol s) [| "b0" |]; - end_basic_block(); - insert "mov" [| "r7" |] [| "gp" |] - end - | Lop(Istackoffset n) -> - end_basic_block(); - insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let load_instr = - match chunk with - | Byte_unsigned -> "ld1" - | Byte_signed -> "ld1" - | Sixteen_unsigned -> "ld2" - | Sixteen_signed -> "ld2" - | Thirtytwo_unsigned -> "ld4" - | Thirtytwo_signed -> "ld4" - | Word -> "ld8" - | Single -> "ldfs" - | Double -> "ldfd" - | Double_u -> "ldfd" in - insert load_instr [| reg i.arg.(0); "heap" |] (regs i.res); - let sext_instr = - match chunk with - Byte_signed -> "sxt1" - | Sixteen_signed -> "sxt2" - | Thirtytwo_signed -> "sxt4" - | _ -> "" in - if sext_instr <> "" then - insert sext_instr (regs i.res) (regs i.res) - | Lop(Istore(chunk, addr)) -> - let store_instr = - match chunk with - | Byte_unsigned -> "st1" - | Byte_signed -> "st1" - | Sixteen_unsigned -> "st2" - | Sixteen_signed -> "st2" - | Thirtytwo_unsigned -> "st4" - | Thirtytwo_signed -> "st4" - | Word -> "st8" - | Single -> "stfs" - | Double -> "stfd" - | Double_u -> "stfd" in - insert store_instr [| reg i.arg.(1); reg i.arg.(0) |] [| "heap" |] - | Lop(Ialloc n) -> - if !fastcode_flag then begin - insimm "addi" [| "r4" |] (string_of_int (-n)) [| "r4" |]; - insert "cmp.ltu" [| "r4"; "r5" |] [| "p6"; "p0" |]; - insimm "movi" [||] (string_of_int n) [| "r2" |]; - insimm "brcallcond" [| "p6" |] "caml_call_gc#" [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n`; - insimm "addi" [| "r4" |] "8" (regs i.res) - end else begin - insimm "movi" [||] (string_of_int n) [| "r2" |]; - insimm "brcall" [||] "caml_allocN#" [| "b0" |]; - end_basic_block(); - `{record_frame i.live}\n`; - insimm "addi" [| "r4" |] "8" (regs i.res) - end - | Lop(Iintop Imul) -> - let t1 = new_temp_float() and t2 = new_temp_float() in - insert "setf.sig" [|reg i.arg.(0)|] [| t1 |]; - insert "setf.sig" [|reg i.arg.(1)|] [| t2 |]; - insert "xmpy.l" [| t1; t2 |] [| t1 |]; - insert "getf.sig" [| t1 |] (regs i.res) - | Lop(Iintop(Icomp cmp)) -> - let comp = "cmpp." ^ name_for_int_comparison cmp in - let p1 = new_pred() and p2 = new_pred() in - insert comp (regs i.arg) [| p1; p2 |]; - insimm "movicond" [| p1 |] "1" (regs i.res); - insimm "movicond" [| p2 |] "0" (regs i.res) - | Lop(Iintop(Icheckbound)) -> - insert "cmp.leu" (regs i.arg) [| "p6"; "p0" |]; - insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#" - [| "b0"; "heap" |] - | Lop(Iintop op) -> - let instr = name_for_int_operation op in - insert instr (regs i.arg) (regs i.res) - | Lop(Iintop_imm(Imul, n)) -> - let src = reg i.arg.(0) and dst = reg i.res.(0) in - begin match ones_pos n with - [] -> - insimm "movi" [||] "0" [|dst|] - | [n] -> - insimm "shli" [|src|] (string_of_int n) [|dst|] - | [n; 0] when n <= 4 -> - insimm "shladd" [|src; src|] (string_of_int n) [|dst|] - | n1::n2::lst -> - let acc1 = new_temp_reg() and acc2 = new_temp_reg() - and tmp1 = new_temp_reg() and tmp2 = new_temp_reg() in - insimm "shli" [|src|] (string_of_int n1) [|acc1|]; - insimm "shli" [|src|] (string_of_int n2) [|acc2|]; - let rec add_shifts a1 t1 a2 t2 = function - [] -> - insert "add" [|a1; a2|] [|dst|] - | n::rem -> - if n = 0 then - insert "add" [|src; a1|] [|a1|] - else if n <= 4 then - insimm "shladd" [|src; a1|] (string_of_int n) [|a1|] - else begin - insimm "shli" [|src|] (string_of_int n) [|t1|]; - insert "add" [|t1; a1|] [|a1|] - end; - add_shifts a2 t2 a1 t1 rem in - add_shifts acc1 tmp1 acc2 tmp2 lst - end - | Lop(Iintop_imm(Idiv, n)) -> (* n must be a power of 2 *) - let src = regs i.arg and dst = regs i.res in - let p1 = new_pred() and p2 = new_pred() in - let l = Misc.log2 n in - insert "cmpp.lt" [| src.(0); "r0" |] [| p1; p2 |]; - if is_immediate_adds (n-1) then - insimm "addicond" [| p1; src.(0) |] (string_of_int (n-1)) dst - else begin - let moveop = if is_immediate_addl (n-1) then "movi" else "movil" in - insimm moveop [||] (string_of_int (n-1)) [| "r2" |]; - insert "addcond" [| p1; src.(0); "r2" |] dst - end; - insert "movcond" [| p2; src.(0) |] dst; - insimm "shri" dst (string_of_int l) dst - | Lop(Iintop_imm(Imod, n)) -> (* n must be a power of 2 *) - let src = regs i.arg and dst = regs i.res in - let p = new_pred() in - let l = Misc.log2 n in - insert "cmpp.lt" [| src.(0); "r0" |] [| p; "p0" |]; - insimm "extr.u" src (sprintf "0, %d" l) dst; - insert "cmpp.ne.and" [| dst.(0); "r0"; p |] [| p; "p0" |]; - if is_immediate_adds (-n) then - insimm "addicond" [| p; dst.(0) |] (string_of_int (-n)) dst - else begin - let moveop = if is_immediate_addl (-n) then "movi" else "movil" in - insimm moveop [||] (string_of_int (-n)) [| "r2" |]; - insert "addcond" [| p; dst.(0); "r2" |] dst - end - | Lop(Iintop_imm(Icomp cmp, n)) -> - let comp = "cmppi." ^ name_for_swapped_int_comparison cmp in - let p1 = new_pred() and p2 = new_pred() in - insimm comp (regs i.arg) (string_of_int n) [| p1; p2 |]; - insimm "movicond" [| p1 |] "1" (regs i.res); - insimm "movicond" [| p2 |] "0" (regs i.res) - | Lop(Iintop_imm(Icheckbound, n)) -> - insimm "cmpi.geu" (regs i.arg) (string_of_int n) [| "p6"; "p0" |]; - insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#" - [| "b0"; "heap" |] - | Lop(Iintop_imm(op, n)) -> - let instr = name_for_int_operation op ^ "i" in - insimm instr (regs i.arg) (string_of_int n) (regs i.res) - | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf as op) -> - let instr = name_for_float_operation op in - insert instr (regs i.arg) (regs i.res) - | Lop(Idivf) -> - (* Straight from the IA64 application developer's architecture guide, - section 13.3.3.1. Modified so that the destination may be equal - to one of the operands *) - let a = reg i.arg.(0) and b = reg i.arg.(1) and r = reg i.res.(0) - and t1 = new_temp_float() and t2 = new_temp_float() - and t3 = new_temp_float() and t4 = new_temp_float() - and p = new_pred() in - insert "frcpa" [| a; b |] [| t1; p |]; - insert "fmas1cond" [| p; a; t1; "f0" |] [| t2 |]; - insert "fnmas1cond" [| p; b; t1; "f1" |] [| t3 |]; - insert "fmas1cond" [| p; t3; t3; t2 |] [| t2 |]; - insert "fmas1cond" [| p; t3; t3; "f0" |] [| t4 |]; - insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |]; - insert "fmas1cond" [| p; t4; t2; t2 |] [| t2 |]; - insert "fmas1cond" [| p; t4; t4; "f0" |] [| t3 |]; - insert "fmas1cond" [| p; t4; t1; t1 |] [| t1 |]; - insert "fmads1cond" [| p; t3; t2; t2 |] [| t2 |]; - insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |]; - insert "fnmads1cond" [| p; b; t2; a |] [| t3 |]; - insert "mov" [| t1 |] [| r |]; - insert "fmacond" [| p; t3; t1; t2 |] [| r |] - | Lop(Ifloatofint) -> - let src = regs i.arg and dst = regs i.res in - insert "setf.sig" src dst; - insert "fcvt.xf" dst dst; - insert "fnorm.d" dst dst - | Lop(Iintoffloat) -> - let src = regs i.arg and dst = regs i.res and tmp = new_temp_float() in - insert "fcvt.fx.trunc" src [| tmp |]; - insert "getf.sig" [| tmp |] dst - | Lop(Ispecific(Iadd1)) -> - let s = if Array.length i.arg >= 2 then 1 else 0 in - insimm "add1" [| reg i.arg.(0); reg i.arg.(s) |] "1" (regs i.res) - | Lop(Ispecific(Isub1)) -> - insimm "sub1" (regs i.arg) "1" (regs i.res) - | Lop(Ispecific(Ishladd n)) -> - insimm "shladd" (regs i.arg) (string_of_int n) (regs i.res) - | Lop(Ispecific(Isignextend n)) -> - let op = "sxt" ^ string_of_int n in - insert op (regs i.arg) (regs i.res) - | Lop(Ispecific (Imultaddf | Imultsubf | Isubmultf as sop)) -> - let name = name_for_specific_operation sop in - insert name (regs i.arg) (regs i.res) - | Lop(Ispecific (Istoreincr n)) -> - let op = if i.arg.(1).typ = Float then "stfd+" else "st8+" in - insimm op [| reg i.arg.(0); reg i.arg.(1) |] - (string_of_int n) - [| reg i.res.(0); "heapinit" |] - | Lop(Ispecific Iinitbarrier) -> - insert "#initbarrier" [| "heapinit" |] [| "heap" |] - | Lreloadretaddr -> - let n = frame_size() + 8 in - let tmp = new_temp_reg() in - insimm "addi" [| "sp" |] (string_of_int n) [| tmp |]; - insert "ld8" [| tmp |] [| tmp |]; - insert "movtb" [| tmp |] [| "b0" |] - | Lreturn -> - let n = frame_size() in - if n > 0 then - insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |]; - insert "brret" [| "b0" |] [||]; - end_basic_block() - | Llabel lbl -> - end_basic_block(); - `{emit_label lbl}:\n` - | Lbranch lbl -> - insimm "br" [||] (label lbl) [||]; - end_basic_block() - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - insimm "cmpi.ne" (regs i.arg) "0" [| "p6"; "p0" |] - | Ifalsetest -> - insimm "cmpi.eq" (regs i.arg) "0" [| "p6"; "p0" |] - | Iinttest cmp -> - let comp = "cmp." ^ name_for_int_comparison cmp in - insert comp (regs i.arg) [| "p6"; "p0" |] - | Iinttest_imm(cmp, n) -> - let comp = "cmpi." ^ name_for_swapped_int_comparison cmp in - insimm comp (regs i.arg) (string_of_int n) [| "p6"; "p0" |] - | Ifloattest(cmp, neg) -> - let comp = "fcmp." ^ name_for_float_comparison cmp in - insert comp (regs i.arg) - (if neg then [| "p0"; "p6" |] - else [| "p6"; "p0" |]) - | Ioddtest -> - insimm "tbit.nz" (regs i.arg) "0" [| "p6"; "p0" |] - | Ieventest -> - insimm "tbit.z" (regs i.arg) "0" [| "p6"; "p0" |] - end; - insimm "brcond" [| "p6" |] (label lbl) [||]; - end_basic_block() - | Lcondbranch3(lbl0, lbl1, lbl2) -> - end_basic_block(); - let emit_compare n p = function - None -> () - | Some lbl -> - ` cmp.eq p{emit_int p}, p0 = {emit_int n}, {emit_reg i.arg.(0)}\n` in - let emit_branch p = function - None -> () - | Some lbl -> - ` (p{emit_int p}) br {emit_label lbl}\n` in - emit_compare 0 5 lbl0; emit_compare 1 6 lbl1; emit_compare 2 7 lbl2; - emit_branch 5 lbl0; emit_branch 6 lbl1; emit_branch 7 lbl2; - ` ;;\n` - | Lswitch jumptbl -> - end_basic_block(); - let numcases = Array.length jumptbl in - if numcases <= 9 then begin - for j = 0 to numcases / 3 do - let n = j * 3 in - for k = 0 to 2 do - if n + k < numcases - 1 then - ` cmp.eq p{emit_int(k+5)}, p0 = {emit_int (n+k)}, {emit_reg i.arg.(0)}\n` - done; - for k = 0 to 2 do - if n + k < numcases - 1 then - ` (p{emit_int(k+5)}) br {emit_label jumptbl.(n+k)}\n` - else if n + k = numcases - 1 then - ` br {emit_label jumptbl.(n+k)}\n` - done; - ` ;;\n` - done - end else if numcases <= 47 then begin - ` mov r2 = 1\n`; - ` cmp.eq p6, p0 = 0, {emit_reg i.arg.(0)}\n`; - ` (p6) br {emit_label jumptbl.(0)} ;;\n`; - ` shl r2 = r2, {emit_reg i.arg.(0)}\n`; - ` cmp.eq p7, p0 = 1, {emit_reg i.arg.(0)}\n`; - ` (p7) br {emit_label jumptbl.(1)} ;;\n`; - ` mov pr = r2, -1 ;;\n`; - for i = 2 to numcases - 1 do - ` (p{emit_int i}) br {emit_label jumptbl.(i)}\n` - done; - ` ;;\n` - end else begin - let lbl_jumptbl = new_label() in - let lbl_ip = new_label() in - `{emit_label lbl_ip}: mov r2 = ip ;;\n`; - ` add r2 = {emit_label lbl_jumptbl} - {emit_label lbl_ip}, r2 ;;\n`; - ` shladd r3 = {emit_reg i.arg.(0)}, 2, r2 ;;\n`; - ` ld4 r3 = [r3] ;;\n`; - ` sxt4 r3 = r3 ;;\n`; - ` add r2 = r2, r3 ;;\n`; - ` mov b6 = r2 ;;\n`; - ` br b6 ;;\n`; - ` .align 4\n`; - `{emit_label lbl_jumptbl}:\n`; - for i = 0 to numcases - 1 do - ` data4 {emit_label jumptbl.(i)} - {emit_label lbl_jumptbl}\n` - done; - ` .align 16\n` - end - | Lsetuptrap lbl -> - end_basic_block(); - let lbl_ip = new_label() in - let lbl_next = new_label() in - `{emit_label lbl_ip}: mov r2 = ip ;;\n`; - ` add r2 = {emit_label lbl_next} - {emit_label lbl_ip}, r2\n`; - ` br.sptk {emit_label lbl} ;;\n`; - `{emit_label lbl_next}:\n` - | Lpushtrap -> - end_basic_block(); - stack_offset := !stack_offset + 16; - (* Store trap pointer at sp, handler addr at sp+8, - and decrement sp by 16. Remember, the bottom 16 bytes - of the stack must be left free. *) - ` add r3 = 8, sp\n`; - ` st8 [sp] = r6, -16 ;;\n`; - ` st8 [r3] = r2\n`; - ` add r6 = 16, sp ;;\n` - | Lpoptrap -> - end_basic_block(); - ` add sp = 16, sp ;;\n`; - ` ld8 r6 = [sp] ;;\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - end_basic_block(); - ` mov sp = r6\n`; - ` add r2 = 8, r6\n`; - ` ld8 r6 = [r6] ;;\n`; - ` ld8 r2 = [r2] ;;\n`; - ` mov b6 = r2 ;;\n`; - ` br b6\n` - -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next - -(* Check if a function contains a tail call to itself *) - -let rec is_tailrec i = - match i.desc with - Lend -> false - | Lop(Itailcall_imm s) when s = !function_name -> true - | _ -> is_tailrec i.next - -(* Emission of a function declaration *) - -let fundecl f = - function_name := f.fun_name; - fastcode_flag := f.fun_fast; - stack_offset := 0; - ` .text\n`; - ` .align 4\n`; - ` .global {emit_symbol f.fun_name}#\n`; - ` .proc {emit_symbol f.fun_name}#\n`; - `{emit_symbol f.fun_name}:\n`; - let n = frame_size() in - if !contains_calls then begin - insert "movfb" [| "b0" |] [| "r2" |]; - insimm "addi" [| "sp" |] "8" [| "r3" |]; - insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; - insert "st8" [| "r3"; "r2" |] [||] - end - else if n > 0 then - insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |]; - if is_tailrec f.fun_body then begin - tailrec_entry_point := new_label(); - end_basic_block(); - `{emit_label !tailrec_entry_point}:\n` - end; - emit_all f.fun_body; - end_basic_block(); - ` .endp {emit_symbol f.fun_name}#\n` - -(* Emission of data *) - -let emit_global_symbol s = - ` .global {emit_symbol s}#\n`; - ` .type {emit_symbol s}#, @object\n`; - ` .size {emit_symbol s}#, 8\n` - -let emit_define_symbol s = - emit_global_symbol s; - `{emit_symbol s}:\n` - -let emit_item = function - Cglobal_symbol s -> - emit_global_symbol s - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` data1 {emit_int n}\n` - | Cint16 n -> - ` data2 {emit_int n}\n` - | Cint32 n -> - let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in - ` data4 {emit_nativeint n'}\n` - | Cint n -> - ` data8 {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive "data4" f - | Cdouble f -> - emit_float64_directive "data8" f - | Csymbol_address s -> - ` data8 {emit_symbol s}#\n` - | Clabel_address lbl -> - ` data8 {emit_label (100000 + lbl)}\n` - | Cstring s -> - emit_string_directive " string " s - | Cskip n -> - if n > 0 then ` .skip {emit_int n}\n` - | Calign n -> - ` .align {emit_int n}\n` - -let data l = - ` .data\n`; - ` .align 8\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - ` .data\n`; - emit_define_symbol (Compilenv.make_symbol (Some "data_begin")); - ` .text\n`; - emit_define_symbol (Compilenv.make_symbol (Some "code_begin")) - -let end_assembly () = - ` .data\n`; - emit_define_symbol (Compilenv.make_symbol (Some "data_end")); - ` .text\n`; - emit_define_symbol (Compilenv.make_symbol (Some "code_end")); - ` .rodata\n`; - ` .align 8\n`; - emit_define_symbol (Compilenv.make_symbol (Some "frametable")); - ` data8 {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml deleted file mode 100644 index 15311aa0..00000000 --- a/asmcomp/ia64/proc.ml +++ /dev/null @@ -1,217 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Description of the IA64 processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Instruction selection *) - -let word_addressed = false - -(* Registers available for register allocation *) - -(* Register map: - r0 always 0 - r1 global pointer (gp) - r2 - r3 temporaries (for the code generator) - r4 allocation pointer - r5 allocation limit - r6 trap pointer - r7 saved gp during C calls (preserved by C) - r8 - r11 0 - 3 function results - r12 stack pointer - r13 reserved by C (thread-specific data) - r14 - r15 80 - 81 temporaries (for accessing stack variables) - r16 - r31 4 - 19 general purpose - r32 - r63 20 - 51 function arguments - r64 - r91 52 - 79 general purpose - r92 - r95 used by C glue code - - We do not use register windows, but instead allocate 64 "out" registers - (r32-r95) when entering Caml code. - - f0 always 0.0 - f1 always 1.0 - f2 - f5 100 - 103 general purpose (preserved by C) - f6 - f7 104 - 105 general purpose - f8 - f15 106 - 113 function results - f16 - f31 114 - 129 function arguments (preserved by C) - f32 - f63 130 - 161 general purpose - f64 - f66 temporaries - f67 - f127 unused -*) - -let int_reg_name = [| - (* 0-3 *) "r8"; "r9"; "r10"; "r11"; - (* 4-19 *) "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; "r22"; "r23"; - "r24"; "r25"; "r26"; "r27"; "r28"; "r29"; "r30"; "r31"; - (* 20-51 *) "r32"; "r33"; "r34"; "r35"; "r36"; "r37"; "r38"; "r39"; - "r40"; "r41"; "r42"; "r43"; "r44"; "r45"; "r46"; "r47"; - "r48"; "r49"; "r50"; "r51"; "r52"; "r53"; "r54"; "r55"; - "r56"; "r57"; "r58"; "r59"; "r60"; "r61"; "r62"; "r63"; - (* 52-79 *) "r64"; "r65"; "r66"; "r67"; "r68"; "r69"; "r70"; "r71"; - "r72"; "r73"; "r74"; "r75"; "r76"; "r77"; "r78"; "r79"; - "r80"; "r81"; "r82"; "r83"; "r84"; "r85"; "r86"; "r87"; - "r88"; "r89"; "r90"; "r91"; - (* 80-81 *) "r14"; "r15" -|] - -let float_reg_name = [| - (* 0-13 *) "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; - "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; - (* 14-29 *) "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; - "f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31"; - (* 30-61 *) "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39"; - "f40"; "f41"; "f42"; "f43"; "f44"; "f45"; "f46"; "f47"; - "f48"; "f49"; "f50"; "f51"; "f52"; "f53"; "f54"; "f55"; - "f56"; "f57"; "f58"; "f59"; "f60"; "f61"; "f62"; "f63" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 80; 62 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 82 Reg.dummy in - for i = 0 to 81 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 62 Reg.dummy in - for i = 0 to 61 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float - lockstep make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int; - if lockstep then incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float; - if lockstep then incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 20 51 114 129 false outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 20 51 114 129 false incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res - in loc -(* Arguments in r32...r39, f8...f15 - Results in r8...r11, f8...f15 *) -let loc_external_arguments arg = - calling_conventions 20 27 106 113 true outgoing arg -let loc_external_results res = - let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res - in loc -let extcall_use_push = false - -let loc_exn_bucket = phys_reg 0 (* r8 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = (* f2...f5, f16...f31 preserved by C *) - Array.append - hard_int_reg - (Array.of_list(List.map phys_reg - [100;101;102;103;104;105;106;107;108;109;110;111;112;113; - 130;131;132;133;134;135;136;137;138;139; - 140;141;142;143;144;145;146;147;148;149; - 150;151;152;153;154;155;156;157;158;159; - 160;161])) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 0 - | _ -> 62 -let max_register_pressure = function - Iextcall(_, _) -> [| 0; 20 |] - | _ -> num_available_registers - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/ia64/reload.ml b/asmcomp/ia64/reload.ml deleted file mode 100644 index 338c0884..00000000 --- a/asmcomp/ia64/reload.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Reloading for the IA64. *) - -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/ia64/scheduling.ml b/asmcomp/ia64/scheduling.ml deleted file mode 100644 index 9bed03a6..00000000 --- a/asmcomp/ia64/scheduling.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Schedgen (* to create a dependency *) - -(* We don't schedule here on the linearized code, but instead schedule the - assembly code generated in Emit. *) - -let fundecl f = f diff --git a/asmcomp/ia64/selection.ml b/asmcomp/ia64/selection.ml deleted file mode 100644 index 6be4a18c..00000000 --- a/asmcomp/ia64/selection.ml +++ /dev/null @@ -1,178 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Instruction selection for the IA64 processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Helper function for add selection *) - -let reassociate_add = function - [Cconst_int n; arg] -> - [arg; Cconst_int n] - | [Cop(Caddi, [arg1; Cconst_int n]); arg3] -> - [Cop(Caddi, [arg1; arg3]); Cconst_int n] - | [Cop(Caddi, [Cconst_int n; arg1]); arg3] -> - [Cop(Caddi, [arg1; arg3]); Cconst_int n] - | [arg1; Cop(Caddi, [Cconst_int n; arg3])] -> - [Cop(Caddi, [arg1; arg3]); Cconst_int n] - | [arg1; Cop(Caddi, [arg2; arg3])] -> - [Cop(Caddi, [arg1; arg2]); arg3] - | args -> args - -(* Helper function for mult-immediate selection *) - -let rec count_one_bits n = - if n = 0 then 0 - else if n land 1 = 0 then count_one_bits (n lsr 1) - else 1 + count_one_bits (n lsr 1) - -class selector = object (self) - -inherit Selectgen.selector_generic as super - -(* Range of immediate arguments: - add 14-bit signed - sub turned into add - sub reversed 8-bit signed - mul at most 16 "one" bits - div, mod powers of 2 - and, or, xor 8-bit signed - lsl, lsr, asr 6-bit unsigned - cmp 8-bit signed - For is_immediate, we put 8-bit signed and treat adds specially - (selectgen already does the right thing for shifts) *) - -method is_immediate n = n >= -128 && n < 128 - -method is_immediate_add n = n >= -8192 && n < 8192 - -method select_addressing arg = (Iindexed, arg) - -method! select_operation op args = - let norm_op = - match op with Cadda -> Caddi | Csuba -> Csubi | _ -> op in - let norm_args = - match norm_op with Caddi -> reassociate_add args | _ -> args in - match (norm_op, norm_args) with - (* Recognize x + y + 1 and x - y - 1 *) - | (Caddi, [Cop(Caddi, [arg1; arg2]); Cconst_int 1]) -> - (Ispecific Iadd1, [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int 1]); Cconst_int 1]) -> - (Ispecific Iadd1, [arg1]) - | (Csubi, [Cop(Csubi, [arg1; arg2]); Cconst_int 1]) -> - (Ispecific Isub1, [arg1; arg2]) - | (Csubi, [Cop(Csubi, [arg1; Cconst_int 1]); arg2]) -> - (Ispecific Isub1, [arg1; arg2]) - (* Recognize add immediate *) - | (Caddi, [arg; Cconst_int n]) when self#is_immediate_add n -> - (Iintop_imm(Iadd, n), [arg]) - (* Turn sub immediate into add immediate *) - | (Csubi, [arg; Cconst_int n]) when self#is_immediate_add (-n) -> - (Iintop_imm(Iadd, -n), [arg]) - (* Recognize imm - arg *) - | (Csubi, [Cconst_int n; arg]) when self#is_immediate n -> - (Iintop_imm(Isub, n), [arg]) - (* Recognize shift-add operations *) - | (Caddi, [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)])]) -> - (Ispecific(Ishladd shift), [arg1; arg2]) - | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)]); arg2]) -> - (Ispecific(Ishladd shift), [arg1; arg2]) - (* Recognize truncation/normalization of 64-bit integers to 32 bits *) - | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) -> - (Ispecific (Isignextend 4), [arg]) - (* Recognize x * cst and cst * x *) - | (Cmuli, [arg; Cconst_int n]) -> - self#select_imul_imm arg n - | (Cmuli, [Cconst_int n; arg]) -> - self#select_imul_imm arg n - (* Prevent the recognition of (x / cst) and (x % cst) when cst is not - a power of 2, which do not correspond to an instruction. - Turn general division and modulus into calls to C library functions *) - | (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> - (Iextcall("__divdi3", false), args) - | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 -> - (Iintop_imm(Imod, n), [arg]) - | (Cmodi, _) -> - (Iextcall("__moddi3", false), args) - (* Recognize mult-add and mult-sub instructions *) - | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> - (Ispecific Imultaddf, [arg1; arg2; arg3]) - | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> - (Ispecific Imultaddf, [arg1; arg2; arg3]) - | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> - (Ispecific Imultsubf, [arg1; arg2; arg3]) - | (Csubf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> - (Ispecific Isubmultf, [arg1; arg2; arg3]) - (* Use default selector otherwise *) - | _ -> - super#select_operation op args - -method private select_imul_imm arg n = - if count_one_bits n <= 16 - then (Iintop_imm(Imul, n), [arg]) - else (Iintop Imul, [arg; Cconst_int n]) - -(* To palliate the lack of addressing with displacement, multiple - stores to the address r are translated as follows - (t1 and t2 are two temp regs) - t1 := r - 8 - t2 := r - compute data1 in reg1 - compute data2 in reg2 - store reg1 at t1 and increment t1 by 16 - store reg2 at t2 and increment t2 by 16 - compute data3 in reg3 - compute data4 in reg4 - store reg3 at t1 and increment t1 by 16 - store reg4 at t2 and increment t2 by 16 - ... - Note: we use two temp regs and perform stores by groups of 2 - in order to expose more instruction-level parallelism. *) -method! emit_stores env data regs_addr = - let t1 = Reg.create Addr and t2 = Reg.create Addr in - self#insert (Iop(Iintop_imm(Iadd, -8))) regs_addr [|t1|]; - self#insert (Iop Imove) regs_addr [|t2|]; - (* Store components by batch of 2 *) - let backlog = ref None in - let do_store r = - match !backlog with - None -> (* keep it for later *) - backlog := Some r - | Some r' -> (* store r' at t1 and r at t2 *) - self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r' |] [| t1 |]; - self#insert (Iop(Ispecific(Istoreincr 16))) [| t2; r |] [| t2 |]; - backlog := None in - List.iter - (fun exp -> - match self#emit_expr env exp with - None -> assert false - | Some regs -> Array.iter do_store regs) - data; - (* Store the backlog if any *) - begin match !backlog with - None -> () - | Some r -> self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r |] [| t1 |] - end; - (* Insert an init barrier *) - self#insert (Iop(Ispecific Iinitbarrier)) [||] [||] -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 30f17b72..f22672b5 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/interf.mli b/asmcomp/interf.mli index 00f4df49..9e16f836 100644 --- a/asmcomp/interf.mli +++ b/asmcomp/interf.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 5833595a..8a541187 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -54,7 +54,8 @@ let has_fallthrough = function type fundecl = { fun_name: string; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } (* Invert a test *) @@ -264,4 +265,5 @@ let rec linear i n = let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; - fun_fast = f.Mach.fun_fast } + fun_fast = f.Mach.fun_fast; + fun_dbg = f.Mach.fun_dbg } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index aaf03184..9fbe14dd 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -49,6 +49,7 @@ val invert_test: Mach.test -> Mach.test type fundecl = { fun_name: string; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 4e743d64..74a034fb 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli index 3353b444..8a25a27b 100644 --- a/asmcomp/liveness.mli +++ b/asmcomp/liveness.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/m68k/README b/asmcomp/m68k/README deleted file mode 100644 index fe5479d4..00000000 --- a/asmcomp/m68k/README +++ /dev/null @@ -1,8 +0,0 @@ -As of Feb 4th 2000, the native-code compiler for the Motorola 680x0 is -no longer maintained and thus deprecated. - -The only machines on which we could test this port (Sun 3, SunOS 4) -here at INRIA are being retired, and were so slow that the port wasn't -kept up-to-date with the remainder of the system. - -- Xavier Leroy, for the Objective Caml development team. diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 027550ab..3d29bde1 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -79,7 +79,8 @@ type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } let rec dummy_instr = { desc = Iend; diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 438d15d2..05cc999b 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -79,7 +79,8 @@ type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } val dummy_instr: instruction val end_instr: unit -> instruction diff --git a/asmcomp/mips/arch.ml b/asmcomp/mips/arch.ml deleted file mode 100644 index c174ef6c..00000000 --- a/asmcomp/mips/arch.ml +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Specific operations for the Mips processor *) - -open Misc -open Format - -(* Machine-specific command-line options *) - -let command_line_options = [] - -(* Addressing modes *) - -type addressing_mode = - Ibased of string * int (* symbol + displ *) - | Iindexed of int (* reg + displ *) - -(* Specific operations *) - -type specific_operation = unit (* none *) - -(* Sizes, endianness *) - -let big_endian = - match Config.system with - "ultrix" -> false - | "irix" -> true - | _ -> fatal_error "Arch_mips.big_endian" - -let size_addr = 4 -let size_int = 4 -let size_float = 8 - -(* Operations on addressing modes *) - -let identity_addressing = Iindexed 0 - -let offset_addressing addr delta = - match addr with - Ibased(s, n) -> Ibased(s, n + delta) - | Iindexed n -> Iindexed(n + delta) - -let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - -(* Printing operations and addressing modes *) - -let print_addressing printreg addr ppf arg = - match addr with - | Ibased(s, n) -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "\"%s\"%s" s idx - | Iindexed n -> - let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in - fprintf ppf "%a%s" printreg arg.(0) idx - -let print_specific_operation printreg op ppf arg = - fatal_error "Arch_mips.print_specific_operation" diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp deleted file mode 100644 index 06915fd3..00000000 --- a/asmcomp/mips/emit.mlp +++ /dev/null @@ -1,593 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Emission of Mips assembly code *) - -open Location -open Misc -open Cmm -open Arch -open Proc -open Reg -open Mach -open Linearize -open Emitaux - -(* Tradeoff between code size and code speed *) - -let fastcode_flag = ref true - -(* Output a label *) - -let emit_label lbl = - emit_string "$"; emit_int lbl - -(* Output a symbol *) - -let emit_symbol s = - Emitaux.emit_symbol '$' s - -(* Output a pseudo-register *) - -let emit_reg r = - match r.loc with - Reg r -> emit_string (register_name r) - | _ -> fatal_error "Emit_mips.emit_reg" - -(* Record if $gp is needed *) - -let uses_gp = ref false - -(* Layout of the stack frame *) - -let stack_offset = ref 0 - -let frame_size () = - let size = - !stack_offset + - 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + - (if !contains_calls then if !uses_gp then 8 else 4 else 0) in - Misc.align size 16 - -let slot_offset loc cl = - match loc with - Incoming n -> frame_size() + n - | Local n -> - if cl = 0 - then !stack_offset + num_stack_slots.(1) * 8 + n * 4 - else !stack_offset + n * 8 - | Outgoing n -> n - -(* Output a stack reference *) - -let emit_stack r = - match r.loc with - Stack s -> - let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)` - | _ -> fatal_error "Emit_mips.emit_stack" - -(* Output an addressing mode *) - -let emit_addressing addr r n = - match addr with - Iindexed ofs -> - `{emit_int ofs}({emit_reg r.(n)})` - | Ibased(s, 0) -> - `{emit_symbol s}` - | Ibased(s, ofs) -> - `{emit_symbol s}`; - if ofs > 0 then ` + {emit_int ofs}`; - if ofs < 0 then ` - {emit_int(-ofs)}` - -(* Communicate live registers at call points to the assembler *) - -let int_reg_number = - [| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |] - -let float_reg_number = - [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; - 20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |] - -let liveregs instr extra_msk = - (* $22, $23, $30 always live *) - let int_mask = ref(0x00000302 lor extra_msk) - and float_mask = ref 0 in - let add_register = function - {loc = Reg r; typ = (Int | Addr)} -> - int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r))) - | {loc = Reg r; typ = Float} -> - float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100))) - | _ -> () in - Reg.Set.iter add_register instr.live; - Array.iter add_register instr.arg; - emit_printf " .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask - -let live_25 = 1 lsl (31 - 25) -let live_24 = 1 lsl (31 - 24) - -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame live = - let lbl = new_label() in - let live_offset = ref [] in - Reg.Set.iter - (function - {typ = Addr; loc = Reg r} -> - live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset - | {typ = Addr; loc = Stack s} as reg -> - live_offset := slot_offset s (register_class reg) :: !live_offset - | _ -> ()) - live; - frame_descriptors := - { fd_lbl = lbl; - fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:` - -let emit_frame fd = - ` .word {emit_label fd.fd_lbl}\n`; - ` .half {emit_int fd.fd_frame_size}\n`; - ` .half {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .half {emit_int n}\n`) - fd.fd_live_offset; - ` .align 2\n` - -(* Determine if $gp is used in the function *) - -let rec instr_uses_gp i = - match i.desc with - Lend -> false - | Lop(Iconst_symbol s) -> true - | Lop(Icall_imm s) -> true - | Lop(Itailcall_imm s) -> true - | Lop(Iextcall(_, _)) -> true - | Lop(Iload(_, Ibased(_, _))) -> true - | Lop(Istore(_, Ibased(_, _))) -> true - | Lop(Ialloc _) -> true - | Lop(Iintop(Icheckbound)) -> true - | Lop(Iintop_imm(Icheckbound, _)) -> true - | Lswitch jumptbl -> true - | _ -> instr_uses_gp i.next - -(* Names of various instructions *) - -let name_for_comparison = function - Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" - | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" - | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "leu" - | Iunsigned Cge -> "geu" | Iunsigned Clt -> "ltu" | Iunsigned Cgt -> "gtu" - -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> ("eq", neg) | Cne -> ("eq", not neg) - | Cle -> ("le", neg) | Cge -> ("ult", not neg) - | Clt -> ("lt", neg) | Cgt -> ("ule", not neg) - -let name_for_int_operation = function - Iadd -> "addu" - | Isub -> "subu" - | Imul -> "mul" - | Idiv -> "div" - | Imod -> "rem" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> "sll" - | Ilsr -> "srl" - | Iasr -> "sra" - | Icomp cmp -> "s" ^ name_for_comparison cmp - | _ -> Misc.fatal_error "Emit.name_for_int_operation" - -let name_for_float_operation = function - Inegf -> "neg.d" - | Iabsf -> "abs.d" - | Iaddf -> "add.d" - | Isubf -> "sub.d" - | Imulf -> "mul.d" - | Idivf -> "div.d" - | _ -> Misc.fatal_error "Emit.name_for_float_operation" - -(* Output the assembly code for an instruction *) - -(* Name of current function *) -let function_name = ref "" -(* Entry point for tail recursive calls *) -let tailrec_entry_point = ref 0 -(* Label of jump to caml_call_gc *) -let call_gc_label = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 - -let emit_instr i = - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src, dst) with - {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} -> - ` move {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> - ` mov.d {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} -> - ` sw {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> - ` s.d {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} -> - ` lw {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> - ` l.d {emit_reg dst}, {emit_stack src}\n` - | _ -> - fatal_error "Emit_mips: Imove" - end - | Lop(Iconst_int n) -> - if n = 0n then - ` move {emit_reg i.res.(0)}, $0\n` - else - ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - ` li.d {emit_reg i.res.(0)}, {emit_string s}\n` - | Lop(Iconst_symbol s) -> - ` la {emit_reg i.res.(0)}, {emit_symbol s}\n` - | Lop(Icall_ind) -> - ` move $25, {emit_reg i.arg.(0)}\n`; - liveregs i live_25; - ` jal {emit_reg i.arg.(0)}\n`; - `{record_frame i.live}\n` - | Lop(Icall_imm s) -> - liveregs i 0; - ` jal {emit_symbol s}\n`; - `{record_frame i.live}\n` - | Lop(Itailcall_ind) -> - let n = frame_size() in - if !contains_calls then - ` lw $31, {emit_int(n - 4)}($sp)\n`; - if !uses_gp then - ` lw $gp, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` addu $sp, $sp, {emit_int n}\n`; - liveregs i 0; - ` move $25, {emit_reg i.arg.(0)}\n`; - liveregs i live_25; - ` j {emit_reg i.arg.(0)}\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then begin - ` b {emit_label !tailrec_entry_point}\n` - end else begin - let n = frame_size() in - if !contains_calls then - ` lw $31, {emit_int(n - 4)}($sp)\n`; - if !uses_gp then - ` lw $gp, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` addu $sp, $sp, {emit_int n}\n`; - ` la $25, {emit_symbol s}\n`; - liveregs i live_25; - ` j $25\n` - end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - ` la $24, {emit_symbol s}\n`; - liveregs i live_24; - ` jal caml_c_call\n`; - `{record_frame i.live}\n` - end else begin - ` jal {emit_symbol s}\n` - end - | Lop(Istackoffset n) -> - if n >= 0 then - ` subu $sp, $sp, {emit_int n}\n` - else - ` addu $sp, $sp, {emit_int (-n)}\n`; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - Double_u -> - (* Destination is not 8-aligned, hence cannot use l.d *) - ` ldl $24, {emit_addressing addr i.arg 0}\n`; - ` ldr $24, {emit_addressing (offset_addressing addr 7) i.arg 0}\n`; - ` dmtc1 $24, {emit_reg dest}\n` - | Single -> - ` l.s {emit_reg dest}, {emit_addressing addr i.arg 0}\n`; - ` cvt.d.s {emit_reg dest}, {emit_reg dest}\n` - | _ -> - let load_instr = - match chunk with - Byte_unsigned -> "lbu" - | Byte_signed -> "lb" - | Sixteen_unsigned -> "lhu" - | Sixteen_signed -> "lh" - | Double -> "l.d" - | _ -> "lw" in - ` {emit_string load_instr} {emit_reg dest}, {emit_addressing addr i.arg 0}\n` - end - | Lop(Istore(chunk, addr)) -> - let src = i.arg.(0) in - begin match chunk with - Double_u -> - (* Destination is not 8-aligned, hence cannot use l.d *) - ` dmfc1 $24, {emit_reg src}\n`; - ` sdl $24, {emit_addressing addr i.arg 1}\n`; - ` sdr $24, {emit_addressing (offset_addressing addr 7) i.arg 1}\n` - | Single -> - ` cvt.s.d $f31, {emit_reg src}\n`; - ` s.s $f31, {emit_addressing addr i.arg 1}\n` - | _ -> - let store_instr = - match chunk with - Byte_unsigned | Byte_signed -> "sb" - | Sixteen_unsigned | Sixteen_signed -> "sh" - | Double -> "s.d" - | _ -> "sw" in - ` {emit_string store_instr} {emit_reg src}, {emit_addressing addr i.arg 1}\n` - end - | Lop(Ialloc n) -> - if !call_gc_label = 0 then call_gc_label := new_label(); - ` .set noreorder\n`; - ` subu $22, $22, {emit_int n}\n`; - ` subu $24, $22, $23\n`; - ` bltzal $24, {emit_label !call_gc_label}\n`; - ` addu {emit_reg i.res.(0)}, $22, 4\n`; - `{record_frame i.live}\n`; - ` .set reorder\n` - | Lop(Iintop(Icheckbound)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label !range_check_trap}\n` - | Lop(Iintop op) -> - let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); - ` bleu {emit_reg i.arg.(0)}, {emit_int n}, {emit_label !range_check_trap}\n` - | Lop(Iintop_imm(op, n)) -> - let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` - | Lop(Inegf | Iabsf as op) -> - let instr = name_for_float_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> - let instr = name_for_float_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` - | Lop(Ifloatofint) -> - ` mtc1 {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; - ` cvt.d.w {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintoffloat) -> - ` trunc.w.d $f31, {emit_reg i.arg.(0)}, $24\n`; - ` mfc1 {emit_reg i.res.(0)}, $f31\n` - | Lop(Ispecific sop) -> - fatal_error "Emit_mips: Ispecific" - | Lreloadretaddr -> - let n = frame_size() in - ` lw $31, {emit_int(n - 4)}($sp)\n`; - | Lreturn -> - let n = frame_size() in - if !uses_gp then - ` lw $gp, {emit_int(n - 8)}($sp)\n`; - if n > 0 then - ` addu $sp, $sp, {emit_int n}\n`; - liveregs i 0; - ` j $31\n` - | Llabel lbl -> - `{emit_label lbl}:\n` - | Lbranch lbl -> - ` b {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - ` bne {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` - | Ifalsetest -> - ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` - | Iinttest cmp -> - let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}, {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - let (comp, branch) = name_for_float_comparison cmp neg in - ` c.{emit_string comp}.d {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - if branch - then ` bc1f {emit_label lbl}\n` - else ` bc1t {emit_label lbl}\n` - | Ioddtest -> - ` and $24, {emit_reg i.arg.(0)}, 1\n`; - ` bne $24, $0, {emit_label lbl}\n` - | Ieventest -> - ` and $24, {emit_reg i.arg.(0)}, 1\n`; - ` beq $24, $0, {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` subu $24, {emit_reg i.arg.(0)}, 1\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` beq {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` beq $24, $0, {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` bgtz $24, {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl_jumptbl = new_label() in - ` sll $24, {emit_reg i.arg.(0)}, 2\n`; - ` lw $24, {emit_label lbl_jumptbl}($24)\n`; - liveregs i live_24; - ` j $24\n`; - ` .rdata\n`; - `{emit_label lbl_jumptbl}:\n`; - for i = 0 to Array.length jumptbl - 1 do - ` .word {emit_label jumptbl.(i)}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` subu $sp, $sp, 16\n`; - ` bal {emit_label lbl}\n` - | Lpushtrap -> - stack_offset := !stack_offset + 16; - ` sw $30, 0($sp)\n`; - ` sw $31, 4($sp)\n`; - ` sw $gp, 8($sp)\n`; - ` move $30, $sp\n` - | Lpoptrap -> - ` lw $30, 0($sp)\n`; - ` addu $sp, $sp, 16\n`; - stack_offset := !stack_offset - 16 - | Lraise -> - ` lw $25, 4($30)\n`; - ` move $sp, $30\n`; - ` lw $30, 0($sp)\n`; - ` lw $gp, 8($sp)\n`; - ` addu $sp, $sp, 16\n`; - liveregs i live_25; - ` jal $25\n` (* Keep retaddr in $31 for debugging *) - -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next - -(* Emission of a function declaration *) - -let fundecl fundecl = - function_name := fundecl.fun_name; - fastcode_flag := fundecl.fun_fast; - uses_gp := instr_uses_gp fundecl.fun_body; - if !uses_gp then contains_calls := true; - tailrec_entry_point := new_label(); - stack_offset := 0; - call_gc_label := 0; - range_check_trap := 0; - ` .text\n`; - ` .align 2\n`; - ` .globl {emit_symbol fundecl.fun_name}\n`; - ` .ent {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; - let n = frame_size() in - if n > 0 then - ` subu $sp, $sp, {emit_int n}\n`; - if !contains_calls then - ` sw $31, {emit_int(n - 4)}($sp)\n`; - if !uses_gp then begin - ` sw $gp, {emit_int(n - 8)}($sp)\n`; - ` lui $24, %hi(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`; - ` addiu $24, $24, %lo(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`; - ` daddu $gp, $25, $24\n` - end; - `{emit_label !tailrec_entry_point}:\n`; - emit_all fundecl.fun_body; - if !call_gc_label > 0 then begin - `{emit_label !call_gc_label}:\n`; - ` la $25, caml_call_gc\n`; - ` j $25\n` - end; - if !range_check_trap > 0 then begin - `{emit_label !range_check_trap}:\n`; - ` la $25, caml_ml_array_bound_error\n`; - ` j $25\n` - end; - ` .end {emit_symbol fundecl.fun_name}\n` - -(* Emission of data *) - -let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_label (100000 + lbl)}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .half {emit_int n}\n` - | Cint32 n -> - ` .word {emit_nativeint n}\n` - | Cint n -> - ` .word {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".word" f - | Cdouble f -> - emit_float64_split_directive ".word" f - | Csymbol_address s -> - ` .word {emit_symbol s}\n` - | Clabel_address lbl -> - ` .word {emit_label (100000 + lbl)}\n` - | Cstring s -> - emit_string_directive " .ascii " s - | Cskip n -> - if n > 0 then ` .space {emit_int n}\n` - | Calign n -> - ` .align {emit_int(Misc.log2 n)}\n` - -let data l = - ` .data\n`; - List.iter emit_item l - -(* Beginning / end of an assembly file *) - -let begin_assembly() = - (* There are really two groups of registers: - $sp and $30 always point to stack locations - $2 - $21 never point to stack locations. *) - ` .noalias $2,$sp; .noalias $2,$30; .noalias $3,$sp; .noalias $3,$30\n`; - ` .noalias $4,$sp; .noalias $4,$30; .noalias $5,$sp; .noalias $5,$30\n`; - ` .noalias $6,$sp; .noalias $6,$30; .noalias $7,$sp; .noalias $7,$30\n`; - ` .noalias $8,$sp; .noalias $8,$30; .noalias $9,$sp; .noalias $9,$30\n`; - ` .noalias $10,$sp; .noalias $10,$30; .noalias $11,$sp; .noalias $11,$30\n`; - ` .noalias $12,$sp; .noalias $12,$30; .noalias $13,$sp; .noalias $13,$30\n`; - ` .noalias $14,$sp; .noalias $14,$30; .noalias $15,$sp; .noalias $15,$30\n`; - ` .noalias $16,$sp; .noalias $16,$30; .noalias $17,$sp; .noalias $17,$30\n`; - ` .noalias $18,$sp; .noalias $18,$30; .noalias $19,$sp; .noalias $19,$30\n`; - ` .noalias $20,$sp; .noalias $20,$30; .noalias $21,$sp; .noalias $21,$30\n\n`; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - ` .ent {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - ` .end {emit_symbol lbl_begin}\n` - -let end_assembly () = - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - ` .globl {emit_symbol lbl_end}\n`; - ` .ent {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .end {emit_symbol lbl_end}\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .data\n`; - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .word 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - ` .rdata\n`; - ` .globl {emit_symbol lbl}\n`; - `{emit_symbol lbl}:\n`; - ` .word {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml deleted file mode 100644 index 53971890..00000000 --- a/asmcomp/mips/proc.ml +++ /dev/null @@ -1,210 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Description of the Mips processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -(* Instruction selection *) - -let word_addressed = false - -(* Registers available for register allocation *) - -(* Register map: - $0 always 0 - $1 temporary for the assembler - $2 - $7 0 - 5 function results - $8 - $15 6 - 13 function arguments - $16 - $21 14 - 19 general purpose (preserved by C) - $22 allocation pointer (preserved by C) - $23 allocation limit (preserved by C) - $24 - $25 temporaries - $26 - $29 kernel regs, stack pointer, global pointer - $30 trap pointer (preserved by C) - $31 return address - - $f0 - $f3 100 - 103 function results - $f4 - $f11 104 - 111 general purpose - $f12 - $f19 112 - 119 function arguments - $f20 - $f30 120 - 130 general purpose (even numbered preserved by C) - $f31 temporary *) - -let int_reg_name = [| - (* 0-5 *) "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; - (* 6-13 *) "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15"; - (* 14-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21" -|] - -let float_reg_name = [| - "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; - "$f5"; "$f6"; "$f7"; "$f8"; "$f9"; - "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; - "$f15"; "$f16"; "$f17"; "$f18"; "$f19"; - "$f20"; "$f21"; "$f22"; "$f23"; "$f24"; - "$f25"; "$f26"; "$f27"; "$f28"; "$f29"; "$f30" -|] - -let num_register_classes = 2 - -let register_class r = - match r.typ with - Int -> 0 - | Addr -> 0 - | Float -> 1 - -let num_available_registers = [| 20; 31 |] - -let first_available_register = [| 0; 100 |] - -let register_name r = - if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) - -let rotate_registers = true - -(* Representation of hard registers by pseudo-registers *) - -let hard_int_reg = - let v = Array.create 20 Reg.dummy in - for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done; - v - -let hard_float_reg = - let v = Array.create 31 Reg.dummy in - for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; - v - -let all_phys_regs = - Array.append hard_int_reg hard_float_reg - -let phys_reg n = - if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) - -let stack_slot slot ty = - Reg.at_location ty (Stack slot) - -(* Calling conventions *) - -let calling_conventions first_int last_int first_float last_float - make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref first_int in - let float = ref first_float in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - match arg.(i).typ with - Int | Addr as ty -> - if !int <= last_int then begin - loc.(i) <- phys_reg !int; - incr int - end else begin - loc.(i) <- stack_slot (make_stack !ofs) ty; - ofs := !ofs + size_int - end - | Float -> - if !float <= last_float then begin - loc.(i) <- phys_reg !float; - incr float - end else begin - loc.(i) <- stack_slot (make_stack !ofs) Float; - ofs := !ofs + size_float - end - done; - (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) - -let incoming ofs = Incoming ofs -let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" - -let loc_arguments arg = - calling_conventions 6 13 112 119 outgoing arg -let loc_parameters arg = - let (loc, ofs) = calling_conventions 6 13 112 119 incoming arg in loc -let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 103 not_supported res in loc - -(* The C calling conventions are as follows: - the first 8 arguments are passed either in integer regs $4...$11 - or float regs $f12...$f19. Each argument "consumes" both one slot - in the int register file and one slot in the float register file. - Extra arguments are passed on stack, in a 64-bits slot, right-justified - (i.e. at +4 from natural address). *) - -let loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in - let int = ref 2 in - let float = ref 112 in - let ofs = ref 0 in - for i = 0 to Array.length arg - 1 do - if i < 8 then begin - loc.(i) <- phys_reg (if arg.(i).typ = Float then !float else !int); - incr int; - incr float - end else begin - begin match arg.(i).typ with - Float -> loc.(i) <- stack_slot (Outgoing !ofs) Float - | ty -> loc.(i) <- stack_slot (Outgoing (!ofs + 4)) ty - end; - ofs := !ofs + 8 - end - done; - (loc, Misc.align !ofs 16) - -let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc - -let loc_exn_bucket = phys_reg 0 (* $2 *) - -(* Registers destroyed by operations *) - -let destroyed_at_c_call = - (* $16 - $21, $f20, $f22, $f24, $f26, $f28, $f30 preserved *) - Array.of_list(List.map phys_reg - [0;1;2;3;4;5;6;7;8;9;10;11;12;13; - 100;101;102;103;104;105;106;107;108;109;110;111;112;113;114; - 115;116;117;118;119;121;123;125;127;129]) - -let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | _ -> [||] - -let destroyed_at_raise = all_phys_regs - -(* Maximal register pressure *) - -let safe_register_pressure = function - Iextcall(_, _) -> 6 - | _ -> 20 -let max_register_pressure = function - Iextcall(_, _) -> [| 6; 6 |] - | _ -> [| 20; 31 |] - -(* Layout of the stack *) - -let num_stack_slots = [| 0; 0 |] -let contains_calls = ref false - -(* Calling the assembler *) - -let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/mips/reload.ml b/asmcomp/mips/reload.ml deleted file mode 100644 index 0bdd208d..00000000 --- a/asmcomp/mips/reload.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -(* Reloading for the Mips *) - -let fundecl f = - (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/mips/scheduling.ml b/asmcomp/mips/scheduling.ml deleted file mode 100644 index 062529ad..00000000 --- a/asmcomp/mips/scheduling.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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$ *) - -open Schedgen (* to create a dependency *) - -(* No scheduling is needed for the Mips, the assembler - does it better than us. *) - -let fundecl f = f diff --git a/asmcomp/mips/selection.ml b/asmcomp/mips/selection.ml deleted file mode 100644 index 4dbaa86e..00000000 --- a/asmcomp/mips/selection.ml +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Instruction selection for the Mips processor *) - -open Misc -open Cmm -open Reg -open Arch -open Mach - -class selector = object - -inherit Selectgen.selector_generic - -method is_immediate (n : int) = true - -method select_addressing = function - Cconst_symbol s -> - (Ibased(s, 0), Ctuple []) - | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> - (Ibased(s, n), Ctuple []) - | Cop(Cadda, [arg; Cconst_int n]) -> - (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> - (Iindexed n, Cop(Cadda, [arg1; arg2])) - | arg -> - (Iindexed 0, arg) - -end - -let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 8828de7c..c0557244 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -46,6 +46,10 @@ let size_addr = if ppc64 then 8 else 4 let size_int = size_addr let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = false + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index b6496f98..38586076 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -73,6 +73,9 @@ let label_prefix = let emit_label lbl = emit_string label_prefix; emit_int lbl +let emit_data_label lbl = + emit_string label_prefix; emit_string "d"; emit_int lbl + (* Section switching *) let data_space = @@ -897,7 +900,7 @@ let emit_item = function | Cdefine_symbol s -> `{emit_symbol s}:\n`; | Cdefine_label lbl -> - `{emit_label (lbl + 100000)}:\n` + `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -915,7 +918,7 @@ let emit_item = function | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> - ` {emit_string datag} {emit_label (lbl + 100000)}\n` + ` {emit_string datag} {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " .byte " s | Cskip n -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index ab8e5a5d..6eaacbba 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/power/reload.ml b/asmcomp/power/reload.ml index 3f74c3f5..ef0ab79d 100644 --- a/asmcomp/power/reload.ml +++ b/asmcomp/power/reload.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index aac37c87..90d08831 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index d87b300c..179548af 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -52,7 +52,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 32767) && (n >= -32768) -method select_addressing exp = +method select_addressing chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml new file mode 100644 index 00000000..3d89f502 --- /dev/null +++ b/asmcomp/printclambda.ml @@ -0,0 +1,132 @@ +(***********************************************************************) +(* *) +(* 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 Format +open Asttypes +open Clambda +open Debuginfo + +let rec pr_idents ppf = function + | [] -> () + | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t + +let rec lam ppf = function + | Uvar id -> + Ident.print ppf id + | Uconst (cst,_) -> + Printlambda.structured_constant ppf cst + | Udirect_apply(f, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs + | Ugeneric_apply(lfun, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs + | Uclosure(clos, fv) -> + let idents ppf = + List.iter (fprintf ppf "@ %a" Ident.print)in + let one_fun ppf f = + fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + f.label f.arity idents f.params lam f.body in + let funs ppf = + List.iter (fprintf ppf "@ %a" one_fun) in + let lams ppf = + List.iter (fprintf ppf "@ %a" lam) in + fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv + | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i + | Ulet(id, arg, body) -> + let rec letbody ul = match ul with + | Ulet(id, arg, body) -> + fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + letbody body + | _ -> ul in + fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Uletrec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Uprim(prim, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs + | Uswitch(larg, sw) -> + 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 + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n 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 + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l; + done in + fprintf ppf + "@[<1>(switch %a@ @[%a@])@]" + lam larg switch sw + | Ustaticfail (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Ucatch(i, vars, lbody, lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> match vars with + | [] -> () + | _ -> + List.iter + (fun x -> fprintf ppf " %a" Ident.print x) + vars) + vars + lam lhandler + | Utrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Ident.print param lam lhandler + | Uifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Usequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Uwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Ufor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Ident.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Uassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Usend (k, met, obj, largs, _) -> + 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 + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + +and sequence ppf ulam = match ulam with + | Usequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | _ -> lam ppf ulam + +let clambda = lam diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli new file mode 100644 index 00000000..ddc233af --- /dev/null +++ b/asmcomp/printclambda.mli @@ -0,0 +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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Clambda +open Format + +val clambda: formatter -> ulambda -> unit diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 364d9ea8..ca1c0f11 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -176,8 +176,9 @@ let fundecl ppf f = if !first then first := false else fprintf ppf "@ "; fprintf ppf "%a: %a" Ident.print id machtype ty) cases in - fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." - f.fun_name print_cases f.fun_args sequence f.fun_body + fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." + (Debuginfo.to_string f.fun_dbg) f.fun_name + print_cases f.fun_args sequence f.fun_body let data_item ppf = function | Cdefine_symbol s -> fprintf ppf "\"%s\":" s diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli index d498ddb7..c6465765 100644 --- a/asmcomp/printcmm.mli +++ b/asmcomp/printcmm.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 3737e72c..754a4361 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -74,4 +74,9 @@ let rec all_instr ppf i = | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next let fundecl ppf f = - fprintf ppf "@[%s:@,%a@]" f.fun_name all_instr f.fun_body + let dbg = + if Debuginfo.is_none f.fun_dbg then + "" + else + " " ^ Debuginfo.to_string f.fun_dbg in + fprintf ppf "@[%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli index 5e90c11c..bb179c94 100644 --- a/asmcomp/printlinear.mli +++ b/asmcomp/printlinear.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index d7d538df..93d0a022 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -182,16 +182,21 @@ let rec instr ppf i = | Iraise -> fprintf ppf "raise %a" reg i.arg.(0) end; - if i.dbg != Debuginfo.none then - fprintf ppf " %s" (Debuginfo.to_string i.dbg); + if not (Debuginfo.is_none i.dbg) then + fprintf ppf "%s" (Debuginfo.to_string i.dbg); begin match i.next.desc with Iend -> () | _ -> fprintf ppf "@,%a" instr i.next end let fundecl ppf f = - fprintf ppf "@[%s(%a)@,%a@]" - f.fun_name regs f.fun_args instr f.fun_body + let dbg = + if Debuginfo.is_none f.fun_dbg then + "" + else + " " ^ Debuginfo.to_string f.fun_dbg in + fprintf ppf "@[%s(%a)%s@,%a@]" + f.fun_name regs f.fun_args dbg instr f.fun_body let phase msg ppf f = fprintf ppf "*** %s@.%a@." msg fundecl f diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli index 28328707..509018d5 100644 --- a/asmcomp/printmach.mli +++ b/asmcomp/printmach.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index ba593592..7d0a5e48 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index f9bef496..30c0ab5a 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index b802344d..11e314f6 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli index fc72446e..ff4b1637 100644 --- a/asmcomp/reload.mli +++ b/asmcomp/reload.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 898c65c9..9da79587 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -134,7 +134,8 @@ method fundecl f = redo_regalloc <- false; let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; - fun_body = new_body; fun_fast = f.fun_fast}, + fun_body = new_body; fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg}, redo_regalloc) end diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli index f0d1c78c..9f0b2b4e 100644 --- a/asmcomp/reloadgen.mli +++ b/asmcomp/reloadgen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 00762fa3..89c031d1 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -349,7 +349,8 @@ method schedule_fundecl f = clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } end else f diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli index ab5f072b..e2c046d2 100644 --- a/asmcomp/schedgen.mli +++ b/asmcomp/schedgen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/scheduling.mli b/asmcomp/scheduling.mli index dd24354a..a006d1f1 100644 --- a/asmcomp/scheduling.mli +++ b/asmcomp/scheduling.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 50f949a7..e2ffd34a 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -204,7 +204,7 @@ method virtual is_immediate : int -> bool (* Selection of addressing modes *) method virtual select_addressing : - Cmm.expression -> Arch.addressing_mode * Cmm.expression + Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Default instruction selection for stores (of words) *) @@ -219,10 +219,10 @@ method select_operation op args = | (Capply(ty, dbg), _) -> (Icall_ind, args) | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) | (Cload chunk, [arg]) -> - let (addr, eloc) = self#select_addressing arg in + let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) | (Cstore chunk, [arg1; arg2]) -> - let (addr, eloc) = self#select_addressing arg1 in + let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin let (op, newarg2) = self#select_store addr arg2 in (op, [newarg2; eloc]) @@ -366,7 +366,7 @@ method insert_move src dst = self#insert (Iop Imove) [|src|] [|dst|] method insert_moves src dst = - for i = 0 to Array.length src - 1 do + for i = 0 to min (Array.length src) (Array.length dst) - 1 do self#insert_move src.(i) dst.(i) done @@ -389,8 +389,7 @@ method insert_op_debug op dbg rs rd = rd method insert_op op rs rd = - self#insert (Iop op) rs rd; - rd + self#insert_op_debug op Debuginfo.none rs rd (* Add the instructions for the given expression at the end of the self sequence *) @@ -490,9 +489,8 @@ method emit_expr env exp = let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in - let loc_res = Proc.loc_external_results rd in - self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg - loc_arg loc_res; + let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg + loc_arg (Proc.loc_external_results rd) in self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> @@ -821,12 +819,13 @@ method emit_fundecl f = { fun_name = f.Cmm.fun_name; fun_args = loc_arg; fun_body = self#extract; - fun_fast = f.Cmm.fun_fast } + fun_fast = f.Cmm.fun_fast; + fun_dbg = f.Cmm.fun_dbg } end (* Tail call criterion (estimated). Assumes: -- all arguments are of type "int" (always the case for Caml function calls) +- all arguments are of type "int" (always the case for OCaml function calls) - one extra argument representing the closure environment (conservative). *) diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 7c30f9f5..058f9e73 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -26,7 +26,7 @@ class virtual selector_generic : object (* Must be defined to indicate whether a constant is a suitable immediate operand to arithmetic instructions *) method virtual select_addressing : - Cmm.expression -> Arch.addressing_mode * Cmm.expression + Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Must be defined to select addressing modes *) method is_simple_expr: Cmm.expression -> bool (* Can be overridden to reflect special extcalls known to be pure *) diff --git a/asmcomp/selection.mli b/asmcomp/selection.mli index ab17b557..a78cb1da 100644 --- a/asmcomp/selection.mli +++ b/asmcomp/selection.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml index 61ba35b9..beaf33a9 100644 --- a/asmcomp/sparc/arch.ml +++ b/asmcomp/sparc/arch.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -47,6 +47,10 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = false + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index f44f813e..ef3fb9a8 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -98,6 +98,9 @@ let label_prefix = let emit_label lbl = emit_string label_prefix; emit_int lbl +let emit_data_label lbl = + emit_string label_prefix; emit_string "d"; emit_int lbl + (* Output a pseudo-register *) let emit_reg r = @@ -714,7 +717,7 @@ let emit_item = function | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> - `{emit_label (lbl + 100000)}:\n` + `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -730,7 +733,7 @@ let emit_item = function | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> - ` .word {emit_label (lbl + 100000)}\n` + ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 2fd147bf..f7b204db 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/sparc/reload.ml b/asmcomp/sparc/reload.ml index a590ba3f..6b1d8aea 100644 --- a/asmcomp/sparc/reload.ml +++ b/asmcomp/sparc/reload.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml index efe9a1f4..180af4b1 100644 --- a/asmcomp/sparc/scheduling.ml +++ b/asmcomp/sparc/scheduling.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 965680b6..e82cc670 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 4095) && (n >= -4096) -method select_addressing = function +method select_addressing chunk = function Cconst_symbol s -> (Ibased(s, 0), Ctuple []) | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 968987d4..7b055959 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -399,4 +399,5 @@ let fundecl f = { fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli index 16a8c01a..4db42222 100644 --- a/asmcomp/spill.mli +++ b/asmcomp/spill.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 9e6130d2..da5cdf1f 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -207,4 +207,5 @@ let fundecl f = { fun_name = f.fun_name; fun_args = new_args; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } diff --git a/asmcomp/split.mli b/asmcomp/split.mli index 67e0956e..baf350d5 100644 --- a/asmcomp/split.mli +++ b/asmcomp/split.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/asmrun/.cvsignore b/asmrun/.cvsignore deleted file mode 100644 index b8ad3e1c..00000000 --- a/asmrun/.cvsignore +++ /dev/null @@ -1,38 +0,0 @@ -libasmrun.a -libasmrunp.a -main.c -misc.c -freelist.c -major_gc.c -minor_gc.c -memory.c -alloc.c -array.c -compare.c -ints.c -floats.c -str.c -io.c -extern.c -intern.c -hash.c -sys.c -parsing.c -gc_ctrl.c -terminfo.c -md5.c -obj.c -lexing.c -printexc.c -callback.c -weak.c -compact.c -finalise.c -custom.c -meta.c -globroots.c -unix.c -dynlink.c -signals.c -debugger.c -.depend.nt diff --git a/asmrun/.depend b/asmrun/.depend index aa0e69e1..1bbfddcd 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -37,9 +37,10 @@ custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h +debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ @@ -51,9 +52,9 @@ extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ @@ -96,14 +97,14 @@ hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ @@ -174,7 +175,8 @@ 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 \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h + ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ @@ -216,8 +218,9 @@ signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h @@ -284,9 +287,10 @@ custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.d.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h +debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ @@ -298,9 +302,9 @@ extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ @@ -343,14 +347,14 @@ hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ @@ -421,7 +425,8 @@ 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 \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h + ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ @@ -463,8 +468,9 @@ signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h @@ -531,9 +537,10 @@ custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.p.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h +debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ @@ -545,9 +552,9 @@ extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ @@ -590,14 +597,14 @@ hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ @@ -668,7 +675,8 @@ 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 \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h + ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ @@ -710,8 +718,9 @@ signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h diff --git a/asmrun/.ignore b/asmrun/.ignore new file mode 100644 index 00000000..a7a9d335 --- /dev/null +++ b/asmrun/.ignore @@ -0,0 +1,40 @@ +*.p.c +*.d.c +libasmrun.a +libasmrunp.a +main.c +misc.c +freelist.c +major_gc.c +minor_gc.c +memory.c +alloc.c +array.c +compare.c +ints.c +floats.c +str.c +io.c +extern.c +intern.c +hash.c +sys.c +parsing.c +gc_ctrl.c +terminfo.c +md5.c +obj.c +lexing.c +printexc.c +callback.c +weak.c +compact.c +finalise.c +custom.c +meta.c +globroots.c +unix.c +dynlink.c +signals.c +debugger.c +.depend.nt diff --git a/asmrun/Makefile b/asmrun/Makefile index 3e37ab1e..2ccfa880 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -34,13 +34,19 @@ OBJS=$(COBJS) $(ASMOBJS) DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o) -all: libasmrun.a all-$(PROFILING) +all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) libasmrun.a: $(OBJS) rm -f libasmrun.a ar rc libasmrun.a $(OBJS) $(RANLIB) libasmrun.a +all-noruntimed: +.PHONY: all-noruntimed + +all-runtimed: libasmrund.a +.PHONY: all-runtimed + libasmrund.a: $(DOBJS) rm -f libasmrund.a ar rc libasmrund.a $(DOBJS) @@ -55,12 +61,20 @@ libasmrunp.a: $(POBJS) ar rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a -install: install-default install-$(PROFILING) +install: install-default install-$(RUNTIMED) install-$(PROFILING) install-default: cp libasmrun.a $(LIBDIR)/libasmrun.a cd $(LIBDIR); $(RANLIB) libasmrun.a +install-noruntimed: +.PHONY: install-noruntimed + +install-runtimed: + cp libasmrund.a $(LIBDIR)/libasmrund.a + cd $(LIBDIR); $(RANLIB) libasmrund.a +.PHONY: install-runtimed + install-noprof: rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a @@ -164,16 +178,14 @@ clean:: $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S .c.d.o: - @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi - $(CC) -c $(DFLAGS) $< - mv $*.o $*.d.o - @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi + ln -s -f $*.c $*.d.c + $(CC) -c $(DFLAGS) $*.d.c + rm -f $*.d.c .c.p.o: - @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi - $(CC) -c $(PFLAGS) $< - mv $*.o $*.p.o - @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi + ln -s -f $*.c $*.p.c + $(CC) -c $(PFLAGS) $*.p.c + rm -f $*.p.c .s.o: $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 75fe2614..81e28901 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -54,6 +54,9 @@ amd64nt.obj: amd64nt.asm i386.o: i386.S $(CC) -c -DSYS_$(SYSTEM) i386.S +amd64.o: amd64.S + $(CC) -c -DSYS_$(SYSTEM) amd64.S + install: cp libasmrun.$(A) $(LIBDIR) diff --git a/asmrun/alpha.S b/asmrun/alpha.S deleted file mode 100644 index c5251b73..00000000 --- a/asmrun/alpha.S +++ /dev/null @@ -1,440 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Alpha processor */ - -/* Allocation */ - - .text - .globl caml_alloc2 - .globl caml_alloc3 - .globl caml_allocN - .globl caml_call_gc - -/* Note: the profiling code sets $27 to the address of the "normal" entrypoint. - So don't pass parameters to those routines in $27. */ - -/* caml_alloc* : all code generator registers preserved, - $gp preserved, $27 not necessarily valid on entry */ - - .globl caml_alloc1 - .ent caml_alloc1 - .align 3 -caml_alloc1: - .prologue 0 - subq $13, 16, $13 - cmpult $13, $14, $25 - bne $25, $100 - ret ($26) -$100: ldiq $25, 16 - br $110 - .end caml_alloc1 - - .globl caml_alloc2 - .ent caml_alloc2 - .align 3 -caml_alloc2: - .prologue 0 - subq $13, 24, $13 - cmpult $13, $14, $25 - bne $25, $101 - ret ($26) -$101: ldiq $25, 24 - br $110 - .end caml_alloc2 - - .globl caml_alloc3 - .ent caml_alloc3 - .align 3 -caml_alloc3: - .prologue 0 - subq $13, 32, $13 - cmpult $13, $14, $25 - bne $25, $102 - ret ($26) -$102: ldiq $25, 32 - br $110 - .end caml_alloc3 - - .globl caml_allocN - .ent caml_allocN - .align 3 -caml_allocN: - .prologue 0 - subq $13, $25, $13 - .set noat - cmpult $13, $14, $at - bne $at, $110 - .set at - ret ($26) - .end caml_allocN - - .globl caml_call_gc - .ent caml_call_gc - .align 3 -caml_call_gc: - .prologue 0 - ldiq $25, 0 -$110: lda $sp, -0x200($sp) - /* 0x200 = 32*8 (ints) + 32*8 (floats) */ - stq $26, 0x1F8($sp) /* return address */ - stq $gp, 0x1F0($sp) /* caller's $gp */ - stq $25, 0x1E8($sp) /* desired size */ - /* Rebuild $gp */ - br $27, $103 -$103: ldgp $gp, 0($27) - /* Record lowest stack address, return address, GC regs */ - stq $26, caml_last_return_address - lda $24, 0x200($sp) - stq $24, caml_bottom_of_stack - lda $24, 0x100($sp) - stq $24, caml_gc_regs - /* Save current allocation pointer for debugging purposes */ -$113: stq $13, caml_young_ptr - /* Save trap pointer in case an exception is raised (e.g. sighandler) */ - stq $15, caml_exception_pointer - /* Save all integer regs used by the code generator in the context */ - stq $0, 0 * 8 ($24) - stq $1, 1 * 8 ($24) - stq $2, 2 * 8 ($24) - stq $3, 3 * 8 ($24) - stq $4, 4 * 8 ($24) - stq $5, 5 * 8 ($24) - stq $6, 6 * 8 ($24) - stq $7, 7 * 8 ($24) - stq $8, 8 * 8 ($24) - stq $9, 9 * 8 ($24) - stq $10, 10 * 8 ($24) - stq $11, 11 * 8 ($24) - stq $12, 12 * 8 ($24) - stq $16, 16 * 8 ($24) - stq $17, 17 * 8 ($24) - stq $18, 18 * 8 ($24) - stq $19, 19 * 8 ($24) - stq $20, 20 * 8 ($24) - stq $21, 21 * 8 ($24) - stq $22, 22 * 8 ($24) - /* Save all float regs that are not callee-save on the stack */ - stt $f0, 0 * 8 ($sp) - stt $f1, 1 * 8 ($sp) - stt $f10, 10 * 8 ($sp) - stt $f11, 11 * 8 ($sp) - stt $f12, 12 * 8 ($sp) - stt $f13, 13 * 8 ($sp) - stt $f14, 14 * 8 ($sp) - stt $f15, 15 * 8 ($sp) - stt $f16, 16 * 8 ($sp) - stt $f17, 17 * 8 ($sp) - stt $f18, 18 * 8 ($sp) - stt $f19, 19 * 8 ($sp) - stt $f20, 20 * 8 ($sp) - stt $f21, 21 * 8 ($sp) - stt $f22, 22 * 8 ($sp) - stt $f23, 23 * 8 ($sp) - stt $f24, 24 * 8 ($sp) - stt $f25, 25 * 8 ($sp) - stt $f26, 26 * 8 ($sp) - stt $f27, 27 * 8 ($sp) - stt $f29, 29 * 8 ($sp) - stt $f30, 30 * 8 ($sp) - /* Call the garbage collector */ - jsr caml_garbage_collection - ldgp $gp, 0($26) - /* Restore all regs used by the code generator */ - lda $24, 0x100($sp) - ldq $0, 0 * 8 ($24) - ldq $1, 1 * 8 ($24) - ldq $2, 2 * 8 ($24) - ldq $3, 3 * 8 ($24) - ldq $4, 4 * 8 ($24) - ldq $5, 5 * 8 ($24) - ldq $6, 6 * 8 ($24) - ldq $7, 7 * 8 ($24) - ldq $8, 8 * 8 ($24) - ldq $9, 9 * 8 ($24) - ldq $10, 10 * 8 ($24) - ldq $11, 11 * 8 ($24) - ldq $12, 12 * 8 ($24) - ldq $16, 16 * 8 ($24) - ldq $17, 17 * 8 ($24) - ldq $18, 18 * 8 ($24) - ldq $19, 19 * 8 ($24) - ldq $20, 20 * 8 ($24) - ldq $21, 21 * 8 ($24) - ldq $22, 22 * 8 ($24) - ldt $f0, 0 * 8 ($sp) - ldt $f1, 1 * 8 ($sp) - ldt $f10, 10 * 8 ($sp) - ldt $f11, 11 * 8 ($sp) - ldt $f12, 12 * 8 ($sp) - ldt $f13, 13 * 8 ($sp) - ldt $f14, 14 * 8 ($sp) - ldt $f15, 15 * 8 ($sp) - ldt $f16, 16 * 8 ($sp) - ldt $f17, 17 * 8 ($sp) - ldt $f18, 18 * 8 ($sp) - ldt $f19, 19 * 8 ($sp) - ldt $f20, 20 * 8 ($sp) - ldt $f21, 21 * 8 ($sp) - ldt $f22, 22 * 8 ($sp) - ldt $f23, 23 * 8 ($sp) - ldt $f24, 24 * 8 ($sp) - ldt $f25, 25 * 8 ($sp) - ldt $f26, 26 * 8 ($sp) - ldt $f27, 27 * 8 ($sp) - ldt $f29, 29 * 8 ($sp) - ldt $f30, 30 * 8 ($sp) - /* Reload new allocation pointer and allocation limit */ - ldq $13, caml_young_ptr - ldq $14, caml_young_limit - /* Allocate space for the block */ - ldq $25, 0x1E8($sp) - subq $13, $25, $13 - cmpult $13, $14, $25 /* Check that we have enough free space */ - bne $25, $113 /* If not, call GC again */ - /* Say that we are back into Caml code */ - stq $31, caml_last_return_address - /* Return to caller */ - ldq $26, 0x1F8($sp) - ldq $gp, 0x1F0($sp) - lda $sp, 0x200($sp) - ret ($26) - - .end caml_call_gc - -/* Call a C function from Caml */ -/* Function to call is in $25 */ - - .globl caml_c_call - .ent caml_c_call - .align 3 -caml_c_call: - .prologue 0 - /* Preserve return address and caller's $gp in callee-save registers */ - mov $26, $9 - mov $gp, $10 - /* Rebuild $gp */ - br $27, $104 -$104: ldgp $gp, 0($27) - /* Record lowest stack address and return address */ - lda $11, caml_last_return_address - stq $26, 0($11) - stq $sp, caml_bottom_of_stack - /* Make the exception handler and alloc ptr available to the C code */ - lda $12, caml_young_ptr - stq $13, 0($12) - lda $14, caml_young_limit - stq $15, caml_exception_pointer - /* Call the function */ - mov $25, $27 - jsr ($25) - /* Reload alloc ptr and alloc limit */ - ldq $13, 0($12) /* $12 still points to caml_young_ptr */ - ldq $14, 0($14) /* $14 still points to caml_young_limit */ - /* Say that we are back into Caml code */ - stq $31, 0($11) /* $11 still points to caml_last_return_address */ - /* Restore $gp */ - mov $10, $gp - /* Return */ - ret ($9) - - .end caml_c_call - -/* Start the Caml program */ - - .globl caml_start_program - .ent caml_start_program - .align 3 -caml_start_program: - ldgp $gp, 0($27) - lda $25, caml_program - -/* Code shared with caml_callback* */ -$107: - /* Save return address */ - lda $sp, -128($sp) - stq $26, 0($sp) - /* Save all callee-save registers */ - stq $9, 8($sp) - stq $10, 16($sp) - stq $11, 24($sp) - stq $12, 32($sp) - stq $13, 40($sp) - stq $14, 48($sp) - stq $15, 56($sp) - stt $f2, 64($sp) - stt $f3, 72($sp) - stt $f4, 80($sp) - stt $f5, 88($sp) - stt $f6, 96($sp) - stt $f7, 104($sp) - stt $f8, 112($sp) - stt $f9, 120($sp) - /* Set up a callback link on the stack. */ - lda $sp, -32($sp) - ldq $0, caml_bottom_of_stack - stq $0, 0($sp) - ldq $1, caml_last_return_address - stq $1, 8($sp) - ldq $1, caml_gc_regs - stq $1, 16($sp) - /* Set up a trap frame to catch exceptions escaping the Caml code */ - lda $sp, -16($sp) - ldq $15, caml_exception_pointer - stq $15, 0($sp) - lda $0, $109 - stq $0, 8($sp) - mov $sp, $15 - /* Reload allocation pointers */ - ldq $13, caml_young_ptr - ldq $14, caml_young_limit - /* We are back into Caml code */ - stq $31, caml_last_return_address - /* Call the Caml code */ - mov $25, $27 -$108: jsr ($25) - /* Reload $gp, masking off low bit in retaddr (might have been marked) */ - bic $26, 1, $26 - ldgp $gp, 4($26) - /* Pop the trap frame, restoring caml_exception_pointer */ - ldq $15, 0($sp) - stq $15, caml_exception_pointer - lda $sp, 16($sp) - /* Pop the callback link, restoring the global variables */ -$112: ldq $24, 0($sp) - stq $24, caml_bottom_of_stack - ldq $25, 8($sp) - stq $25, caml_last_return_address - ldq $24, 16($sp) - stq $24, caml_gc_regs - lda $sp, 32($sp) - /* Update allocation pointer */ - stq $13, caml_young_ptr - /* Reload callee-save registers */ - ldq $9, 8($sp) - ldq $10, 16($sp) - ldq $11, 24($sp) - ldq $12, 32($sp) - ldq $13, 40($sp) - ldq $14, 48($sp) - ldq $15, 56($sp) - ldt $f2, 64($sp) - ldt $f3, 72($sp) - ldt $f4, 80($sp) - ldt $f5, 88($sp) - ldt $f6, 96($sp) - ldt $f7, 104($sp) - ldt $f8, 112($sp) - ldt $f9, 120($sp) - /* Return to caller */ - ldq $26, 0($sp) - lda $sp, 128($sp) - ret ($26) - - /* The trap handler */ -$109: ldgp $gp, 0($26) - /* Save exception pointer */ - stq $15, caml_exception_pointer - /* Encode exception bucket as an exception result */ - or $0, 2, $0 - /* Return it */ - br $112 - - .end caml_start_program - -/* Raise an exception from C */ - - .globl caml_raise_exception - .ent caml_raise_exception - .align 3 -caml_raise_exception: - ldgp $gp, 0($27) - mov $16, $0 /* Move exn bucket */ - ldq $13, caml_young_ptr - ldq $14, caml_young_limit - stq $31, caml_last_return_address /* We're back into Caml */ - ldq $sp, caml_exception_pointer - ldq $15, 0($sp) - ldq $26, 8($sp) - lda $sp, 16($sp) - jmp $25, ($26) /* Keep retaddr in $25 to help debugging */ - .end caml_raise_exception - -/* Callback from C to Caml */ - - .globl caml_callback_exn - .ent caml_callback_exn - .align 3 -caml_callback_exn: - /* Initial shuffling of arguments */ - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $25, $17 /* environment */ - ldq $25, 0($25) /* code pointer */ - br $107 - .end caml_callback_exn - - .globl caml_callback2_exn - .ent caml_callback2_exn - .align 3 -caml_callback2_exn: - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $18, $17 /* second arg */ - mov $25, $18 /* environment */ - lda $25, caml_apply2 - br $107 - .end caml_callback2_exn - - .globl caml_callback3_exn - .ent caml_callback3_exn - .align 3 -caml_callback3_exn: - ldgp $gp, 0($27) - mov $16, $25 - mov $17, $16 /* first arg */ - mov $18, $17 /* second arg */ - mov $19, $18 /* third arg */ - mov $25, $19 /* environment */ - lda $25, caml_apply3 - br $107 - .end caml_callback3_exn - -/* Glue code to call [caml_array_bound_error] */ - - .globl caml_ml_array_bound_error - .ent caml_ml_array_bound_error - .align 3 -caml_ml_array_bound_error: - br $27, $111 -$111: ldgp $gp, 0($27) - lda $25, caml_array_bound_error - br caml_c_call /* never returns */ - .end caml_ml_array_bound_error - -#if defined(SYS_digital) - .rdata -#else - .section .rodata -#endif - .globl caml_system__frametable -caml_system__frametable: - .quad 1 /* one descriptor */ - .quad $108 + 4 /* return address into callback */ - .word -1 /* negative frame size => use callback link */ - .word 0 /* no roots here */ - .align 3 diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 645c2e61..715e796b 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -18,8 +18,11 @@ /* PIC mode support based on contribution by Paul Stravers (see PR#4795) */ -#ifdef SYS_macosx +#include "../config/m.h" +#if defined(SYS_macosx) + +#define LBL(x) L##x #define G(r) _##r #define GREL(r) _##r@GOTPCREL #define GCALL(r) _##r @@ -31,8 +34,23 @@ .align FUNCTION_ALIGN; \ name: +#elif defined(SYS_mingw64) + +#define LBL(x) .L##x +#define G(r) r +#undef GREL +#define GCALL(r) r +#define FUNCTION_ALIGN 4 +#define EIGHT_ALIGN 8 +#define SIXTEEN_ALIGN 16 +#define FUNCTION(name) \ + .globl name; \ + .align FUNCTION_ALIGN; \ + name: + #else +#define LBL(x) .L##x #define G(r) r #define GREL(r) r@GOTPCREL #define GCALL(r) r@PLT @@ -47,7 +65,17 @@ #endif -#ifdef __PIC__ +#ifdef 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 + +#if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ @@ -118,15 +146,108 @@ leaq 8+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_bottom_of_stack) +#endif + +/* Save and restore all callee-save registers on stack. + Keep the stack 16-aligned. */ + +#if defined(SYS_mingw64) + +/* 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; \ + movupd %xmm6, 0*16(%rsp); \ + movupd %xmm7, 1*16(%rsp); \ + movupd %xmm8, 2*16(%rsp); \ + movupd %xmm9, 3*16(%rsp); \ + movupd %xmm10, 4*16(%rsp); \ + movupd %xmm11, 5*16(%rsp); \ + movupd %xmm12, 6*16(%rsp); \ + movupd %xmm13, 7*16(%rsp); \ + movupd %xmm14, 8*16(%rsp); \ + movupd %xmm15, 9*16(%rsp) + +#define POP_CALLEE_SAVE_REGS \ + movupd 0*16(%rsp), %xmm6; \ + movupd 1*16(%rsp), %xmm7; \ + movupd 2*16(%rsp), %xmm8; \ + movupd 3*16(%rsp), %xmm9; \ + movupd 4*16(%rsp), %xmm10; \ + movupd 5*16(%rsp), %xmm11; \ + movupd 6*16(%rsp), %xmm12; \ + 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 + +#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 + +#define POP_CALLEE_SAVE_REGS \ + addq $8, %rsp; \ + popq %r15; \ + popq %r14; \ + popq %r13; \ + popq %r12; \ + popq %rbp; \ + popq %rbx + +#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 +#else +# define PREPARE_FOR_C_CALL +# define CLEANUP_AFTER_C_CALL #endif .text + .globl G(caml_system__code_begin) +G(caml_system__code_begin): + /* Allocation */ FUNCTION(G(caml_call_gc)) + CFI_STARTPROC RECORD_STACK_FRAME(0) -.Lcaml_call_gc: +LBL(caml_call_gc): +#ifndef SYS_mingw64 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subq $32768, %rsp + movq %rax, 0(%rsp) + addq $32768, %rsp +#endif /* Build array of registers, save it into caml_gc_regs */ pushq %r13 pushq %r12 @@ -147,6 +268,7 @@ FUNCTION(G(caml_call_gc)) STORE_VAR(%r14, caml_exception_pointer) /* Save floating-point registers */ subq $(16*8), %rsp + CFI_ADJUST(232) movsd %xmm0, 0*8(%rsp) movsd %xmm1, 1*8(%rsp) movsd %xmm2, 2*8(%rsp) @@ -164,7 +286,9 @@ FUNCTION(G(caml_call_gc)) movsd %xmm14, 14*8(%rsp) movsd %xmm15, 15*8(%rsp) /* Call the garbage collector */ + PREPARE_FOR_C_CALL call GCALL(caml_garbage_collection) + CLEANUP_AFTER_C_CALL /* Restore caml_young_ptr, caml_exception_pointer */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) @@ -199,74 +323,85 @@ FUNCTION(G(caml_call_gc)) popq %rbp popq %r12 popq %r13 + CFI_ADJUST(-232) /* Return to caller */ ret + CFI_ENDPROC FUNCTION(G(caml_alloc1)) -.Lcaml_alloc1: +LBL(caml_alloc1): subq $16, %r15 CMP_VAR(caml_young_limit, %r15) - jb .L100 + jb LBL(100) ret -.L100: +LBL(100): RECORD_STACK_FRAME(0) subq $8, %rsp - call .Lcaml_call_gc + call LBL(caml_call_gc) addq $8, %rsp - jmp .Lcaml_alloc1 + jmp LBL(caml_alloc1) FUNCTION(G(caml_alloc2)) -.Lcaml_alloc2: +LBL(caml_alloc2): subq $24, %r15 CMP_VAR(caml_young_limit, %r15) - jb .L101 + jb LBL(101) ret -.L101: +LBL(101): RECORD_STACK_FRAME(0) subq $8, %rsp - call .Lcaml_call_gc + call LBL(caml_call_gc) addq $8, %rsp - jmp .Lcaml_alloc2 + jmp LBL(caml_alloc2) FUNCTION(G(caml_alloc3)) -.Lcaml_alloc3: +LBL(caml_alloc3): subq $32, %r15 CMP_VAR(caml_young_limit, %r15) - jb .L102 + jb LBL(102) ret -.L102: +LBL(102): RECORD_STACK_FRAME(0) subq $8, %rsp - call .Lcaml_call_gc + call LBL(caml_call_gc) addq $8, %rsp - jmp .Lcaml_alloc3 + jmp LBL(caml_alloc3) FUNCTION(G(caml_allocN)) -.Lcaml_allocN: +LBL(caml_allocN): pushq %rax /* save desired size */ subq %rax, %r15 CMP_VAR(caml_young_limit, %r15) - jb .L103 + jb LBL(103) addq $8, %rsp /* drop desired size */ ret -.L103: +LBL(103): RECORD_STACK_FRAME(8) - call .Lcaml_call_gc + call LBL(caml_call_gc) popq %rax /* recover desired size */ - jmp .Lcaml_allocN + jmp LBL(caml_allocN) -/* Call a C function from Caml */ +/* Call a C function from OCaml */ FUNCTION(G(caml_c_call)) -.Lcaml_c_call: +LBL(caml_c_call): /* Record lowest stack address and return address */ popq %r12 STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) +#ifndef SYS_mingw64 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subq $32768, %rsp + movq %rax, 0(%rsp) + addq $32768, %rsp +#endif /* Make the exception handler and alloc ptr available to the C code */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) /* Call the function (address in %rax) */ + /* No need to PREPARE_FOR_C_CALL since the caller already + reserved the stack space if needed (cf. amd64/proc.ml) */ call *%rax /* Reload alloc ptr */ LOAD_VAR(caml_young_ptr, %r15) @@ -274,41 +409,40 @@ FUNCTION(G(caml_c_call)) pushq %r12 ret -/* Start the Caml program */ +/* Start the OCaml program */ FUNCTION(G(caml_start_program)) + CFI_STARTPROC /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ + 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* */ -.Lcaml_start_program: +LBL(caml_start_program): /* Build a callback link */ subq $8, %rsp /* 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 .L108(%rip), %r13 + lea LBL(108)(%rip), %r13 pushq %r13 pushq %r14 + CFI_ADJUST(16) movq %rsp, %r14 - /* Call the Caml code */ + /* Call the OCaml code */ call *%r12 -.L107: +LBL(107): /* Pop the exception handler */ popq %r14 popq %r12 /* dummy register */ -.L109: + CFI_ADJUST(-16) +LBL(109): /* Update alloc ptr and exception ptr */ STORE_VAR(%r15,caml_young_ptr) STORE_VAR(%r14,caml_exception_pointer) @@ -318,35 +452,45 @@ FUNCTION(G(caml_start_program)) POP_VAR(caml_gc_regs) addq $8, %rsp /* Restore callee-save registers. */ - addq $8, %rsp - popq %r15 - popq %r14 - popq %r13 - popq %r12 - popq %rbp - popq %rbx + POP_CALLEE_SAVE_REGS /* Return to caller. */ ret -.L108: +LBL(108): /* Exception handler*/ /* Mark the bucket as an exception result and return it */ orq $2, %rax - jmp .L109 + jmp LBL(109) + CFI_ENDPROC + +/* Registers holding arguments of C functions. */ + +#ifdef SYS_mingw64 +#define C_ARG_1 %rcx +#define C_ARG_2 %rdx +#define C_ARG_3 %r8 +#define C_ARG_4 %r9 +#else +#define C_ARG_1 %rdi +#define C_ARG_2 %rsi +#define C_ARG_3 %rdx +#define C_ARG_4 %rcx +#endif -/* Raise an exception from Caml */ +/* Raise an exception from OCaml */ FUNCTION(G(caml_raise_exn)) TESTL_VAR($1, caml_backtrace_active) - jne .L110 + jne LBL(110) movq %r14, %rsp popq %r14 ret -.L110: +LBL(110): movq %rax, %r12 /* Save exception bucket */ - movq %rax, %rdi /* arg 1: exception bucket */ - movq 0(%rsp), %rsi /* arg 2: pc of raise */ - leaq 8(%rsp), %rdx /* arg 3: sp of raise */ - movq %r14, %rcx /* arg 4: sp of handler */ + movq %rax, C_ARG_1 /* arg 1: exception bucket */ + movq 0(%rsp), C_ARG_2 /* arg 2: pc of raise */ + leaq 8(%rsp), C_ARG_3 /* arg 3: sp of raise */ + movq %r14, C_ARG_4 /* arg 4: sp of handler */ + PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ movq %r14, %rsp @@ -357,18 +501,19 @@ FUNCTION(G(caml_raise_exn)) FUNCTION(G(caml_raise_exception)) TESTL_VAR($1, caml_backtrace_active) - jne .L111 - movq %rdi, %rax + jne LBL(111) + movq C_ARG_1, %rax LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */ popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */ ret -.L111: - movq %rdi, %r12 /* Save exception bucket */ +LBL(111): + movq C_ARG_1, %r12 /* Save exception bucket */ /* arg 1: exception bucket */ - LOAD_VAR(caml_last_return_address,%rsi) /* arg 2: pc of raise */ - LOAD_VAR(caml_bottom_of_stack,%rdx) /* arg 3: sp of raise */ - LOAD_VAR(caml_exception_pointer,%rcx) /* arg 4: sp of handler */ + 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 */ + 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) @@ -376,72 +521,59 @@ FUNCTION(G(caml_raise_exception)) LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ ret -/* Callback from C to Caml */ +/* Callback from C to OCaml */ FUNCTION(G(caml_callback_exn)) /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ + PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ - movq %rdi, %rbx /* closure */ - movq %rsi, %rax /* argument */ - movq 0(%rbx), %r12 /* code pointer */ - jmp .Lcaml_start_program + movq C_ARG_1, %rbx /* closure */ + movq C_ARG_2, %rax /* argument */ + movq 0(%rbx), %r12 /* code pointer */ + jmp LBL(caml_start_program) FUNCTION(G(caml_callback2_exn)) /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ + PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ - /* closure stays in %rdi */ - movq %rsi, %rax /* first argument */ - movq %rdx, %rbx /* second argument */ + movq C_ARG_1, %rdi /* closure -- no op with Unix conventions */ + movq C_ARG_2, %rax /* first argument */ + movq C_ARG_3, %rbx /* second argument */ leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */ - jmp .Lcaml_start_program + jmp LBL(caml_start_program) FUNCTION(G(caml_callback3_exn)) /* Save callee-save registers */ - pushq %rbx - pushq %rbp - pushq %r12 - pushq %r13 - pushq %r14 - pushq %r15 - subq $8, %rsp /* stack 16-aligned */ + PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ - movq %rsi, %rax /* first argument */ - movq %rdx, %rbx /* second argument */ - movq %rdi, %rsi /* closure */ - movq %rcx, %rdi /* third argument */ + movq C_ARG_2, %rax /* first argument */ + movq C_ARG_3, %rbx /* second argument */ + movq C_ARG_1, %rsi /* closure */ + movq C_ARG_4, %rdi /* third argument */ leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */ - jmp .Lcaml_start_program + jmp LBL(caml_start_program) FUNCTION(G(caml_ml_array_bound_error)) leaq GCALL(caml_array_bound_error)(%rip), %rax - jmp .Lcaml_c_call + jmp LBL(caml_c_call) + + .globl G(caml_system__code_end) +G(caml_system__code_end): .data .globl G(caml_system__frametable) .align EIGHT_ALIGN G(caml_system__frametable): .quad 1 /* one descriptor */ - .quad .L107 /* return address into callback */ + .quad LBL(107) /* return address into callback */ .value -1 /* negative frame size => use callback link */ .value 0 /* no roots here */ .align EIGHT_ALIGN -#ifdef SYS_macosx +#if defined(SYS_macosx) .literal16 +#elif defined(SYS_mingw64) + .section .rdata,"dr" #else .section .rodata.cst8,"a",@progbits #endif diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index 4c31bc87..7dfb3143 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -1,15 +1,15 @@ -;********************************************************************* -; -; Objective Caml -; -; Xavier Leroy, projet Gallium, 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 GNU Library General Public License, with -; the special exception on linking described in file ../LICENSE. -; -;********************************************************************* +;*********************************************************************** +;* * +;* OCaml * +;* * +;* Xavier Leroy, projet Gallium, 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 GNU Library General Public License, with * +;* the special exception on linking described in file ../LICENSE. * +;* * +;*********************************************************************** ; $Id$ @@ -192,7 +192,7 @@ L103: pop rax ; recover desired size jmp caml_allocN -; Call a C function from Caml +; Call a C function from OCaml PUBLIC caml_c_call ALIGN 16 @@ -212,7 +212,7 @@ caml_c_call: push r12 ret -; Start the Caml program +; Start the OCaml program PUBLIC caml_start_program ALIGN 16 @@ -254,7 +254,7 @@ L106: push r13 push r14 mov r14, rsp - ; Call the Caml code + ; Call the OCaml code call r12 L107: ; Pop the exception handler @@ -297,7 +297,7 @@ L108: or rax, 2 jmp L109 -; Raise an exception from Caml +; Raise an exception from OCaml PUBLIC caml_raise_exn ALIGN 16 @@ -346,7 +346,7 @@ L111: mov r15, caml_young_ptr ; Reload alloc ptr ret -; Callback from C to Caml +; Callback from C to OCaml PUBLIC caml_callback_exn ALIGN 16 diff --git a/asmrun/arm.S b/asmrun/arm.S index 8a47d182..64829566 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -1,275 +1,411 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* Benedikt Meurer, University of Siegen */ /* */ -/* Copyright 1998 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. */ +/* Copyright 1998 Institut National de Recherche en Informatique */ +/* et en Automatique. Copyright 2012 Benedikt Meurer. 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. */ /* */ /***********************************************************************/ /* $Id$ */ /* Asm part of the runtime system, ARM processor */ +/* Must be preprocessed by cpp */ -trap_ptr .req r11 -alloc_ptr .req r8 -alloc_limit .req r10 - + .syntax unified .text +#if defined(SYS_linux_eabihf) + .arch armv7-a + .fpu vfpv3-d16 + .thumb +#elif defined(SYS_linux_eabi) + .arch armv4t + .arm + + /* Compatibility macros */ + .macro blx reg + mov lr, pc + bx \reg + .endm + .macro cbz reg, lbl + 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 profiling with gprof */ + +#if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi)) +#define PROFILE \ + push {lr}; \ + bl __gnu_mcount_nc +#else +#define PROFILE +#endif /* Allocation functions and GC interface */ - .globl caml_call_gc + .globl caml_system__code_begin +caml_system__code_begin: + + .align 2 + .globl caml_call_gc + .type caml_call_gc, %function caml_call_gc: - /* Record return address and desired size */ - /* Can use alloc_limit as a temporary since it will be reloaded by - invoke_gc */ - ldr alloc_limit, .Lcaml_last_return_address - str lr, [alloc_limit, #0] - ldr alloc_limit, .Lcaml_requested_size - str r12, [alloc_limit, #0] - /* Branch to shared GC code */ - bl .Linvoke_gc - /* Finish allocation */ - ldr r12, .Lcaml_requested_size - ldr r12, [r12, #0] - sub alloc_ptr, alloc_ptr, r12 + PROFILE + /* Record return address */ + ldr r12, =caml_last_return_address + str lr, [r12] +.Lcaml_call_gc: + /* Record lowest stack address */ + ldr r12, =caml_bottom_of_stack + str sp, [r12] + /* Save caller floating-point registers on the stack */ + vpush {d0-d7} + /* Save integer registers and return address on the stack */ + push {r0-r7,r12,lr} + /* Store pointer to saved integer registers in caml_gc_regs */ + ldr r12, =caml_gc_regs + str sp, [r12] + /* Save current allocation pointer for debugging purposes */ + ldr alloc_limit, =caml_young_ptr + str alloc_ptr, [alloc_limit] + /* Save trap pointer in case an exception is raised during GC */ + ldr r12, =caml_exception_pointer + str trap_ptr, [r12] + /* Call the garbage collector */ + bl caml_garbage_collection + /* Restore integer registers and return address from the stack */ + pop {r0-r7,r12,lr} + /* Restore floating-point registers from the stack */ + vpop {d0-d7} + /* Reload new allocation pointer and limit */ + /* alloc_limit still points to caml_young_ptr */ + ldr r12, =caml_young_limit + ldr alloc_ptr, [alloc_limit] + ldr alloc_limit, [r12] + /* Return to caller */ bx lr + .type caml_call_gc, %function + .size caml_call_gc, .-caml_call_gc - .globl caml_alloc1 + .align 2 + .globl caml_alloc1 + .type caml_alloc1, %function caml_alloc1: - sub alloc_ptr, alloc_ptr, #8 + PROFILE +.Lcaml_alloc1: + sub alloc_ptr, alloc_ptr, 8 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r12, .Lcaml_last_return_address - str lr, [r12, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r7, =caml_last_return_address + str lr, [r7] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr lr, [r7] /* Try again */ - b caml_alloc1 + b .Lcaml_alloc1 + .type caml_alloc1, %function + .size caml_alloc1, .-caml_alloc1 - .globl caml_alloc2 + .align 2 + .globl caml_alloc2 + .type caml_alloc2, %function caml_alloc2: - sub alloc_ptr, alloc_ptr, #12 + PROFILE +.Lcaml_alloc2: + sub alloc_ptr, alloc_ptr, 12 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r12, .Lcaml_last_return_address - str lr, [r12, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r7, =caml_last_return_address + str lr, [r7] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr lr, [r7] /* Try again */ - b caml_alloc2 + b .Lcaml_alloc2 + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 - .globl caml_alloc3 + .align 2 + .globl caml_alloc3 + .type caml_alloc3, %function caml_alloc3: - sub alloc_ptr, alloc_ptr, #16 + PROFILE +.Lcaml_alloc3: + sub alloc_ptr, alloc_ptr, 16 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r12, .Lcaml_last_return_address - str lr, [r12, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r7, =caml_last_return_address + str lr, [r7] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr lr, [r7] /* Try again */ - b caml_alloc3 + b .Lcaml_alloc3 + .type caml_alloc3, %function + .size caml_alloc3, .-caml_alloc3 - .globl caml_allocN + .align 2 + .globl caml_allocN + .type caml_allocN, %function caml_allocN: - sub alloc_ptr, alloc_ptr, r12 + PROFILE +.Lcaml_allocN: + sub alloc_ptr, alloc_ptr, r7 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address and desired size */ - /* Can use alloc_limit as a temporary since it will be reloaded by - invoke_gc */ - ldr alloc_limit, .Lcaml_last_return_address - str lr, [alloc_limit, #0] - ldr alloc_limit, .Lcaml_requested_size - str r12, [alloc_limit, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r12, =caml_last_return_address + str lr, [r12] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr r12, =caml_last_return_address + ldr lr, [r12] /* Try again */ - ldr r12, .Lcaml_requested_size - ldr r12, [r12, #0] - b caml_allocN - -/* Shared code to invoke the GC */ -.Linvoke_gc: - /* Record lowest stack address */ - ldr r12, .Lcaml_bottom_of_stack - str sp, [r12, #0] - /* Save integer registers and return address on stack */ - stmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12,lr} - /* Store pointer to saved integer registers in caml_gc_regs */ - ldr r12, .Lcaml_gc_regs - str sp, [r12, #0] - /* Save current allocation pointer for debugging purposes */ - ldr r12, .Lcaml_young_ptr - str alloc_ptr, [r12, #0] - /* Save trap pointer in case an exception is raised during GC */ - ldr r12, .Lcaml_exception_pointer - str trap_ptr, [r12, #0] - /* Call the garbage collector */ - bl caml_garbage_collection - /* Restore the registers from the stack */ - ldmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12} - /* Reload return address */ - ldr r12, .Lcaml_last_return_address - ldr lr, [r12, #0] - /* Reload new allocation pointer and allocation limit */ - ldr r12, .Lcaml_young_ptr - ldr alloc_ptr, [r12, #0] - ldr r12, .Lcaml_young_limit - ldr alloc_limit, [r12, #0] - /* Return to caller */ - ldr r12, [sp], #4 - bx r12 + b .Lcaml_allocN + .type caml_allocN, %function + .size caml_allocN, .-caml_allocN -/* Call a C function from Caml */ -/* Function to call is in r12 */ +/* Call a C function from OCaml */ +/* Function to call is in r7 */ - .globl caml_c_call + .align 2 + .globl caml_c_call + .type caml_c_call, %function caml_c_call: + PROFILE + /* Record lowest stack address and return address */ + ldr r5, =caml_last_return_address + ldr r6, =caml_bottom_of_stack + str lr, [r5] + str sp, [r6] /* Preserve return address in callee-save register r4 */ mov r4, lr - /* Record lowest stack address and return address */ - ldr r5, .Lcaml_last_return_address - ldr r6, .Lcaml_bottom_of_stack - str lr, [r5, #0] - str sp, [r6, #0] - /* Make the exception handler and alloc ptr available to the C code */ - ldr r6, .Lcaml_young_ptr - ldr r7, .Lcaml_exception_pointer - str alloc_ptr, [r6, #0] - str trap_ptr, [r7, #0] + /* Make the exception handler alloc ptr available to the C code */ + ldr r5, =caml_young_ptr + ldr r6, =caml_exception_pointer + str alloc_ptr, [r5] + str trap_ptr, [r6] /* Call the function */ - mov lr, pc - bx r12 + blx r7 /* Reload alloc ptr and alloc limit */ - ldr r5, .Lcaml_young_limit - ldr alloc_ptr, [r6, #0] /* r6 still points to caml_young_ptr */ - ldr alloc_limit, [r5, #0] + ldr r6, =caml_young_limit + ldr alloc_ptr, [r5] /* r5 still points to caml_young_ptr */ + ldr alloc_limit, [r6] /* Return */ bx r4 + .type caml_c_call, %function + .size caml_c_call, .-caml_c_call -/* Start the Caml program */ +/* Start the OCaml program */ - .globl caml_start_program + .align 2 + .globl caml_start_program + .type caml_start_program, %function caml_start_program: - ldr r12, .Lcaml_program + PROFILE + ldr r12, =caml_program /* Code shared with caml_callback* */ -/* Address of Caml code to call is in r12 */ -/* Arguments to the Caml code are in r0...r3 */ +/* Address of OCaml code to call is in r12 */ +/* Arguments to the OCaml code are in r0...r3 */ .Ljump_to_caml: /* Save return address and callee-save registers */ - stmfd sp!, {r4,r5,r6,r7,r8,r10,r11,lr} /* 8-alignment */ + vpush {d8-d15} + push {r4-r8,r10,r11,lr} /* 8-byte alignment */ /* Setup a callback link on the stack */ - sub sp, sp, #4*4 /* 8-alignment */ - ldr r4, .Lcaml_bottom_of_stack - ldr r4, [r4, #0] - str r4, [sp, #0] - ldr r4, .Lcaml_last_return_address - ldr r4, [r4, #0] - str r4, [sp, #4] - ldr r4, .Lcaml_gc_regs - ldr r4, [r4, #0] - str r4, [sp, #8] - /* Setup a trap frame to catch exceptions escaping the Caml code */ - sub sp, sp, #4*2 - ldr r4, .Lcaml_exception_pointer - ldr r4, [r4, #0] - str r4, [sp, #0] - ldr r4, .LLtrap_handler - str r4, [sp, #4] + sub sp, sp, 4*4 /* 8-byte alignment */ + ldr r4, =caml_bottom_of_stack + ldr r5, =caml_last_return_address + ldr r6, =caml_gc_regs + ldr r4, [r4] + ldr r5, [r5] + ldr r6, [r6] + str r4, [sp, 0] + str r5, [sp, 4] + str r6, [sp, 8] + /* Setup a trap frame to catch exceptions escaping the OCaml code */ + sub sp, sp, 2*4 + ldr r6, =caml_exception_pointer + ldr r5, =.Ltrap_handler + ldr r4, [r6] + str r4, [sp, 0] + str r5, [sp, 4] mov trap_ptr, sp /* Reload allocation pointers */ - ldr r4, .Lcaml_young_ptr - ldr alloc_ptr, [r4, #0] - ldr r4, .Lcaml_young_limit - ldr alloc_limit, [r4, #0] - /* Call the Caml code */ - mov lr, pc - bx r12 + ldr r4, =caml_young_ptr + ldr alloc_ptr, [r4] + ldr r4, =caml_young_limit + ldr alloc_limit, [r4] + /* Call the OCaml code */ + blx r12 .Lcaml_retaddr: /* Pop the trap frame, restoring caml_exception_pointer */ - ldr r4, .Lcaml_exception_pointer - ldr r5, [sp, #0] - str r5, [r4, #0] - add sp, sp, #2 * 4 + ldr r4, =caml_exception_pointer + ldr r5, [sp, 0] + str r5, [r4] + add sp, sp, 2*4 /* Pop the callback link, restoring the global variables */ .Lreturn_result: - ldr r4, .Lcaml_bottom_of_stack - ldr r5, [sp, #0] - str r5, [r4, #0] - ldr r4, .Lcaml_last_return_address - ldr r5, [sp, #4] - str r5, [r4, #0] - ldr r4, .Lcaml_gc_regs - ldr r5, [sp, #8] - str r5, [r4, #0] - add sp, sp, #4*4 + ldr r4, =caml_bottom_of_stack + ldr r5, [sp, 0] + str r5, [r4] + ldr r4, =caml_last_return_address + ldr r5, [sp, 4] + str r5, [r4] + ldr r4, =caml_gc_regs + ldr r5, [sp, 8] + str r5, [r4] + add sp, sp, 4*4 /* Update allocation pointer */ - ldr r4, .Lcaml_young_ptr - str alloc_ptr, [r4, #0] + ldr r4, =caml_young_ptr + str alloc_ptr, [r4] /* Reload callee-save registers and return */ - ldmfd sp!, {r4,r5,r6,r7,r8,r10,r11,lr} - bx lr + pop {r4-r8,r10,r11,lr} + vpop {d8-d15} + bx lr + .type .Lcaml_retaddr, %function + .size .Lcaml_retaddr, .-.Lcaml_retaddr + .type caml_start_program, %function + .size caml_start_program, .-caml_start_program + +/* The trap handler */ - /* The trap handler */ + .align 2 .Ltrap_handler: /* Save exception pointer */ - ldr r4, .Lcaml_exception_pointer - str trap_ptr, [r4, #0] + ldr r12, =caml_exception_pointer + str trap_ptr, [r12] /* Encode exception bucket as an exception result */ - orr r0, r0, #2 + orr r0, r0, 2 /* Return it */ b .Lreturn_result + .type .Ltrap_handler, %function + .size .Ltrap_handler, .-.Ltrap_handler + +/* Raise an exception from OCaml */ + + .align 2 + .globl caml_raise_exn +caml_raise_exn: + PROFILE + /* Test if backtrace is active */ + ldr r1, =caml_backtrace_active + ldr r1, [r1] + cbz r1, 1f + /* Preserve exception bucket in callee-save register r4 */ + mov r4, r0 + /* Stash the backtrace */ + mov r1, lr /* arg2: pc of raise */ + mov r2, sp /* arg3: sp of raise */ + mov r3, trap_ptr /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket */ + mov r0, r4 +1: /* Cut stack at current trap handler */ + mov sp, trap_ptr + /* Pop previous handler and addr of trap, and jump to it */ + pop {trap_ptr, pc} + .type caml_raise_exn, %function + .size caml_raise_exn, .-caml_raise_exn /* Raise an exception from C */ - .globl caml_raise_exception + .align 2 + .globl caml_raise_exception + .type caml_raise_exception, %function caml_raise_exception: - /* Reload Caml allocation pointers */ - ldr r12, .Lcaml_young_ptr - ldr alloc_ptr, [r12, #0] - ldr r12, .Lcaml_young_limit - ldr alloc_limit, [r12, #0] - /* Cut stack at current trap handler */ - ldr r12, .Lcaml_exception_pointer - ldr sp, [r12, #0] + PROFILE + /* Reload trap ptr, alloc ptr and alloc limit */ + ldr trap_ptr, =caml_exception_pointer + ldr alloc_ptr, =caml_young_ptr + ldr alloc_limit, =caml_young_limit + ldr trap_ptr, [trap_ptr] + ldr alloc_ptr, [alloc_ptr] + ldr alloc_limit, [alloc_limit] + /* Test if backtrace is active */ + ldr r1, =caml_backtrace_active + ldr r1, [r1] + cbz r1, 1f + /* Preserve exception bucket in callee-save register r4 */ + mov r4, r0 + ldr r1, =caml_last_return_address /* arg2: pc of raise */ + ldr r1, [r1] + ldr r2, =caml_bottom_of_stack /* arg3: sp of raise */ + ldr r2, [r2] + mov r3, trap_ptr /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket */ + mov r0, r4 +1: /* Cut stack at current trap handler */ + mov sp, trap_ptr /* Pop previous handler and addr of trap, and jump to it */ - ldmfd sp!, {trap_ptr, pc} + pop {trap_ptr, pc} + .type caml_raise_exception, %function + .size caml_raise_exception, .-caml_raise_exception -/* Callback from C to Caml */ +/* Callback from C to OCaml */ - .globl caml_callback_exn + .align 2 + .globl caml_callback_exn + .type caml_callback_exn, %function caml_callback_exn: + PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ mov r12, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r12 /* r1 = closure environment */ - ldr r12, [r12, #0] /* code pointer */ + mov r0, r1 /* r0 = first arg */ + mov r1, r12 /* r1 = closure environment */ + ldr r12, [r12] /* code pointer */ b .Ljump_to_caml + .type caml_callback_exn, %function + .size caml_callback_exn, .-caml_callback_exn - .globl caml_callback2_exn + .align 2 + .globl caml_callback2_exn + .type caml_callback2_exn, %function caml_callback2_exn: + PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ mov r12, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r2 /* r1 = second arg */ - mov r2, r12 /* r2 = closure environment */ - ldr r12, .Lcaml_apply2 + mov r0, r1 /* r0 = first arg */ + mov r1, r2 /* r1 = second arg */ + mov r2, r12 /* r2 = closure environment */ + ldr r12, =caml_apply2 b .Ljump_to_caml + .type caml_callback2_exn, %function + .size caml_callback2_exn, .-caml_callback2_exn - .globl caml_callback3_exn + .align 2 + .globl caml_callback3_exn + .type caml_callback3_exn, %function caml_callback3_exn: + PROFILE /* Initial shuffling of arguments */ /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ mov r12, r0 @@ -277,42 +413,36 @@ caml_callback3_exn: mov r1, r2 /* r1 = second arg */ mov r2, r3 /* r2 = third arg */ mov r3, r12 /* r3 = closure environment */ - ldr r12, .Lcaml_apply3 + ldr r12, =caml_apply3 b .Ljump_to_caml + .type caml_callback3_exn, %function + .size caml_callback3_exn, .-caml_callback3_exn - .globl caml_ml_array_bound_error + .align 2 + .globl caml_ml_array_bound_error + .type caml_ml_array_bound_error, %function caml_ml_array_bound_error: - /* Load address of [caml_array_bound_error] in r12 */ - ldr r12, .Lcaml_array_bound_error + PROFILE + /* Load address of [caml_array_bound_error] in r7 */ + ldr r7, =caml_array_bound_error /* Call that function */ b caml_c_call + .type caml_ml_array_bound_error, %function + .size caml_ml_array_bound_error, .-caml_ml_array_bound_error -/* Global references */ - -.Lcaml_last_return_address: .word caml_last_return_address -.Lcaml_bottom_of_stack: .word caml_bottom_of_stack -.Lcaml_gc_regs: .word caml_gc_regs -.Lcaml_young_ptr: .word caml_young_ptr -.Lcaml_young_limit: .word caml_young_limit -.Lcaml_exception_pointer: .word caml_exception_pointer -.Lcaml_program: .word caml_program -.LLtrap_handler: .word .Ltrap_handler -.Lcaml_apply2: .word caml_apply2 -.Lcaml_apply3: .word caml_apply3 -.Lcaml_array_bound_error: .word caml_array_bound_error -.Lcaml_requested_size: .word caml_requested_size - - .data -caml_requested_size: - .word 0 + .globl caml_system__code_end +caml_system__code_end: /* GC roots for callback */ .data - .globl caml_system__frametable + .align 2 + .globl caml_system__frametable caml_system__frametable: .word 1 /* one descriptor */ .word .Lcaml_retaddr /* return address into callback */ .short -1 /* negative frame size => use callback link */ .short 0 /* no roots */ .align 2 + .type caml_system__frametable, %object + .size caml_system__frametable, .-caml_system__frametable diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 0825cade..7b47c0bf 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ /* */ @@ -193,7 +193,7 @@ void caml_print_exception_backtrace(void) } } -/* Convert the backtrace to a data structure usable from Caml */ +/* Convert the backtrace to a data structure usable from OCaml */ CAMLprim value caml_get_exception_backtrace(value unit) { diff --git a/asmrun/fail.c b/asmrun/fail.c index a1ec0fb0..77cf4246 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -41,7 +41,9 @@ extern caml_generated_constant caml_exn_Not_found, caml_exn_Match_failure, caml_exn_Sys_blocked_io, - caml_exn_Stack_overflow; + caml_exn_Stack_overflow, + caml_exn_Assert_failure, + caml_exn_Undefined_recursive_module; extern caml_generated_constant caml_bucket_Out_of_memory, caml_bucket_Stack_overflow; @@ -205,3 +207,9 @@ void caml_array_bound_error(void) } caml_raise((value) &array_bound_error_bucket.exn); } + +int caml_is_special_exception(value exn) { + return exn == (value) caml_exn_Match_failure + || exn == (value) caml_exn_Assert_failure + || exn == (value) caml_exn_Undefined_recursive_module; +} diff --git a/asmrun/hppa.S b/asmrun/hppa.S deleted file mode 100644 index abdd4554..00000000 --- a/asmrun/hppa.S +++ /dev/null @@ -1,534 +0,0 @@ -;********************************************************************* -;* * -;* Objective Caml * -;* * -;* 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. * -;* * -;********************************************************************* - -; $Id$ - -; Asm part of the runtime system for the HP PA-RISC processor. -; Must be preprocessed by cpp - -#ifdef SYS_hpux -#define G(x) x -#define CODESPACE .code -#define CODE_ALIGN 4 -#define EXPORT_CODE(x) .export x, entry, priv_lev=3 -#define EXPORT_DATA(x) .export x, data -#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry -#define ENDPROC .exit ! .procend -#define LOADHIGH(x) addil LR%x-$global$, %r27 -#define LOW(x) RR%x-$global$ -#define LOADHIGHLABEL(x) ldil LR%x, %r1 -#define LOWLABEL(x) RR%x -#endif - -#if defined(SYS_linux) || defined(SYS_gnu) -#define G(x) x -#define CODESPACE .text -#define CODE_ALIGN 8 -#define EXPORT_CODE(x) .globl x -#define EXPORT_DATA(x) .globl x -#define STARTPROC -#define ENDPROC -#define LOADHIGH(x) addil LR%x-$global$, %r27 -#define LOW(x) RR%x-$global$ -#define LOADHIGHLABEL(x) ldil LR%x, %r1 -#define LOWLABEL(x) RR%x -#endif - -#ifdef SYS_hpux - .space $PRIVATE$ - .subspa $DATA$,quad=1,align=8,access=31 - .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82 - .space $TEXT$ - .subspa $LIT$,quad=0,align=8,access=44 - .subspa $CODE$,quad=0,align=8,access=44,code_only - .import $global$, data - .import $$dyncall, millicode - .import caml_garbage_collection, code - .import caml_program, code - .import caml_raise, code - .import caml_apply2, code - .import caml_apply3, code - .import caml_array_bound_error, code - -caml_young_limit .comm 8 -caml_young_ptr .comm 8 -caml_bottom_of_stack .comm 8 -caml_last_return_address .comm 8 -caml_gc_regs .comm 8 -caml_exception_pointer .comm 8 -caml_required_size .comm 8 -#endif - -#if defined(SYS_linux) || defined(SYS_gnu) - .align 8 - .comm G(young_limit), 4 - .comm G(young_ptr), 4 - .comm G(caml_bottom_of_stack), 4 - .comm G(caml_last_return_address), 4 - .comm G(caml_gc_regs), 4 - .comm G(caml_exception_pointer), 4 - .comm G(caml_required_size), 4 -#endif - -; Allocation functions - - CODESPACE - .align CODE_ALIGN - EXPORT_CODE(G(caml_allocN)) -G(caml_allocN): - STARTPROC -; Required size in %r29 - ldw 0(%r4), %r1 - sub %r3, %r29, %r3 - comb,<<,n %r3, %r1, G(caml_call_gc) ; nullify if taken (forward br.) - bv 0(%r2) - nop - ENDPROC - - EXPORT_CODE(G(caml_call_gc)) -G(caml_call_gc): - STARTPROC -; Save required size (%r29) - LOADHIGH(G(caml_required_size)) - stw %r29, LOW(G(caml_required_size))(%r1) -; Save current allocation pointer for debugging purposes - LOADHIGH(G(caml_young_ptr)) - stw %r3, LOW(G(caml_young_ptr))(%r1) -; Record lowest stack address - LOADHIGH(G(caml_bottom_of_stack)) - stw %r30, LOW(G(caml_bottom_of_stack))(%r1) -; Record return address - LOADHIGH(G(caml_last_return_address)) - stw %r2, LOW(G(caml_last_return_address))(%r1) -; Save the exception handler (if e.g. a sighandler raises) - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Reserve stack space -; 0x1C0 = 4 * 32 (int regs) + 8 * 32 (float regs) + 64 (for calling C) - ldo 0x1C0(%r30), %r30 -; Save caml_gc_regs -L100: ldo -(64 + 4*32)(%r30), %r31 - LOADHIGH(G(caml_gc_regs)) - stw %r31, LOW(G(caml_gc_regs))(%r1) -; Save all regs used by the code generator - copy %r31, %r1 - stws,ma %r6, 4(%r1) - stws,ma %r7, 4(%r1) - stws,ma %r8, 4(%r1) - stws,ma %r9, 4(%r1) - stws,ma %r10, 4(%r1) - stws,ma %r11, 4(%r1) - stws,ma %r12, 4(%r1) - stws,ma %r13, 4(%r1) - stws,ma %r14, 4(%r1) - stws,ma %r15, 4(%r1) - stws,ma %r16, 4(%r1) - stws,ma %r17, 4(%r1) - stws,ma %r18, 4(%r1) - stws,ma %r19, 4(%r1) - stws,ma %r20, 4(%r1) - stws,ma %r21, 4(%r1) - stws,ma %r22, 4(%r1) - stws,ma %r23, 4(%r1) - stws,ma %r24, 4(%r1) - stws,ma %r25, 4(%r1) - stws,ma %r26, 4(%r1) - stws,ma %r28, 4(%r1) - ldo -0x1C0(%r30), %r1 - fstds,ma %fr4, 8(%r1) - fstds,ma %fr5, 8(%r1) - fstds,ma %fr6, 8(%r1) - fstds,ma %fr7, 8(%r1) - fstds,ma %fr8, 8(%r1) - fstds,ma %fr9, 8(%r1) - fstds,ma %fr10, 8(%r1) - fstds,ma %fr11, 8(%r1) - fstds,ma %fr12, 8(%r1) - fstds,ma %fr13, 8(%r1) - fstds,ma %fr14, 8(%r1) - fstds,ma %fr15, 8(%r1) - fstds,ma %fr16, 8(%r1) - fstds,ma %fr17, 8(%r1) - fstds,ma %fr18, 8(%r1) - fstds,ma %fr19, 8(%r1) - fstds,ma %fr20, 8(%r1) - fstds,ma %fr21, 8(%r1) - fstds,ma %fr22, 8(%r1) - fstds,ma %fr23, 8(%r1) - fstds,ma %fr24, 8(%r1) - fstds,ma %fr25, 8(%r1) - fstds,ma %fr26, 8(%r1) - fstds,ma %fr27, 8(%r1) - fstds,ma %fr28, 8(%r1) - fstds,ma %fr29, 8(%r1) - fstds,ma %fr30, 8(%r1) - -; Call the garbage collector - bl G(caml_garbage_collection), %r2 - nop - -; Restore all regs used by the code generator - ldo -(64 + 4*32)(%r30), %r1 - ldws,ma 4(%r1), %r6 - ldws,ma 4(%r1), %r7 - ldws,ma 4(%r1), %r8 - ldws,ma 4(%r1), %r9 - ldws,ma 4(%r1), %r10 - ldws,ma 4(%r1), %r11 - ldws,ma 4(%r1), %r12 - ldws,ma 4(%r1), %r13 - ldws,ma 4(%r1), %r14 - ldws,ma 4(%r1), %r15 - ldws,ma 4(%r1), %r16 - ldws,ma 4(%r1), %r17 - ldws,ma 4(%r1), %r18 - ldws,ma 4(%r1), %r19 - ldws,ma 4(%r1), %r20 - ldws,ma 4(%r1), %r21 - ldws,ma 4(%r1), %r22 - ldws,ma 4(%r1), %r23 - ldws,ma 4(%r1), %r24 - ldws,ma 4(%r1), %r25 - ldws,ma 4(%r1), %r26 - ldws,ma 4(%r1), %r28 - ldo -0x1C0(%r30), %r1 - fldds,ma 8(%r1), %fr4 - fldds,ma 8(%r1), %fr5 - fldds,ma 8(%r1), %fr6 - fldds,ma 8(%r1), %fr7 - fldds,ma 8(%r1), %fr8 - fldds,ma 8(%r1), %fr9 - fldds,ma 8(%r1), %fr10 - fldds,ma 8(%r1), %fr11 - fldds,ma 8(%r1), %fr12 - fldds,ma 8(%r1), %fr13 - fldds,ma 8(%r1), %fr14 - fldds,ma 8(%r1), %fr15 - fldds,ma 8(%r1), %fr16 - fldds,ma 8(%r1), %fr17 - fldds,ma 8(%r1), %fr18 - fldds,ma 8(%r1), %fr19 - fldds,ma 8(%r1), %fr20 - fldds,ma 8(%r1), %fr21 - fldds,ma 8(%r1), %fr22 - fldds,ma 8(%r1), %fr23 - fldds,ma 8(%r1), %fr24 - fldds,ma 8(%r1), %fr25 - fldds,ma 8(%r1), %fr26 - fldds,ma 8(%r1), %fr27 - fldds,ma 8(%r1), %fr28 - fldds,ma 8(%r1), %fr29 - fldds,ma 8(%r1), %fr30 - -; Reload the allocation pointer - LOADHIGH(G(caml_young_ptr)) - ldw LOW(G(caml_young_ptr))(%r1), %r3 -; Allocate space for block - LOADHIGH(G(caml_required_size)) - ldw LOW(G(caml_required_size))(%r1), %r29 - ldw 0(%r4), %r1 - sub %r3, %r29, %r3 - comb,<< %r3, %r1, L100 - nop -; Return to caller - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r2 - bv 0(%r2) - ldo -0x1C0(%r30), %r30 - ENDPROC - -; Call a C function from Caml -; Function to call is in %r22 - - .align CODE_ALIGN -#ifdef SYS_hpux - .export G(caml_c_call), ENTRY, ARGW0=GR, ARGW1=GR, ARGW2=GR, ARGW3=GR -#else - EXPORT_CODE(G(caml_c_call)) -#endif -G(caml_c_call): - STARTPROC -; Record lowest stack address - LOADHIGH(G(caml_bottom_of_stack)) - stw %r30, LOW(G(caml_bottom_of_stack))(%r1) -; Record return address - LOADHIGH(G(caml_last_return_address)) - stw %r2, LOW(G(caml_last_return_address))(%r1) -; Save the exception handler - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Save the allocation pointer - LOADHIGH(G(caml_young_ptr)) - stw %r3, LOW(G(caml_young_ptr))(%r1) -; Call the C function -#ifdef SYS_hpux - bl $$dyncall, %r31 -#else - ble 0(4, %r22) -#endif - copy %r31, %r2 ; in delay slot -; Reload return address - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r2 -; Reload allocation pointer - LOADHIGH(G(caml_young_ptr)) -; Return to caller - bv 0(%r2) - ldw LOW(G(caml_young_ptr))(%r1), %r3 ; in delay slot - ENDPROC - -; Start the Caml program - - .align CODE_ALIGN - EXPORT_CODE(G(caml_start_program)) -G(caml_start_program): - STARTPROC - LOADHIGH(G(caml_program)) - ldo LOW(G(caml_program))(%r1), %r22 - -; Code shared with caml_callback* -L102: -; Save return address - stw %r2,-20(%r30) - ldo 256(%r30), %r30 -; Save the callee-save registers - ldo -32(%r30), %r1 - stws,ma %r3, -4(%r1) - stws,ma %r4, -4(%r1) - stws,ma %r5, -4(%r1) - stws,ma %r6, -4(%r1) - stws,ma %r7, -4(%r1) - stws,ma %r8, -4(%r1) - stws,ma %r9, -4(%r1) - stws,ma %r10, -4(%r1) - stws,ma %r11, -4(%r1) - stws,ma %r12, -4(%r1) - stws,ma %r13, -4(%r1) - stws,ma %r14, -4(%r1) - stws,ma %r15, -4(%r1) - stws,ma %r16, -4(%r1) - stws,ma %r17, -4(%r1) - stws,ma %r18, -4(%r1) - fstds,ma %fr12, -8(%r1) - fstds,ma %fr13, -8(%r1) - fstds,ma %fr14, -8(%r1) - fstds,ma %fr15, -8(%r1) - fstds,ma %fr16, -8(%r1) - fstds,ma %fr17, -8(%r1) - fstds,ma %fr18, -8(%r1) - fstds,ma %fr19, -8(%r1) - fstds,ma %fr20, -8(%r1) - fstds,ma %fr21, -8(%r1) - fstds,ma %fr22, -8(%r1) - fstds,ma %fr23, -8(%r1) - fstds,ma %fr24, -8(%r1) - fstds,ma %fr25, -8(%r1) - fstds,ma %fr26, -8(%r1) - fstds,ma %fr27, -8(%r1) - fstds,ma %fr28, -8(%r1) - fstds,ma %fr29, -8(%r1) - fstds,ma %fr30, -8(%r1) - fstds,ma %fr31, -8(%r1) -; Set up a callback link - ldo 16(%r30), %r30 - LOADHIGH(G(caml_bottom_of_stack)) - ldw LOW(G(caml_bottom_of_stack))(%r1), %r1 - stw %r1, -16(%r30) - LOADHIGH(G(caml_last_return_address)) - ldw LOW(G(caml_last_return_address))(%r1), %r1 - stw %r1, -12(%r30) - LOADHIGH(G(caml_gc_regs)) - ldw LOW(G(caml_gc_regs))(%r1), %r1 - stw %r1, -8(%r30) -; Set up a trap frame to catch exceptions escaping the Caml code - ldo 8(%r30), %r30 - LOADHIGH(G(caml_exception_pointer)) - ldw LOW(G(caml_exception_pointer))(%r1), %r1 - stw %r1, -8(%r30) - LOADHIGHLABEL(L103) - ldo LOWLABEL(L103)(%r1), %r1 - stw %r1, -4(%r30) - copy %r30, %r5 -; Reload allocation pointers - LOADHIGH(G(caml_young_ptr)) - ldw LOW(G(caml_young_ptr))(%r1), %r3 - LOADHIGH(G(caml_young_limit)) - ldo LOW(G(caml_young_limit))(%r1), %r4 -; Call the Caml code - ble 0(4, %r22) - copy %r31, %r2 -L104: -; Pop the trap frame - ldw -8(%r30), %r31 - LOADHIGH(G(caml_exception_pointer)) - stw %r31, LOW(G(caml_exception_pointer))(%r1) - ldo -8(%r30), %r30 -; Pop the callback link -L105: - ldw -16(%r30), %r31 - LOADHIGH(G(caml_bottom_of_stack)) - stw %r31, LOW(G(caml_bottom_of_stack))(%r1) - ldw -12(%r30), %r31 - LOADHIGH(G(caml_last_return_address)) - stw %r31, LOW(G(caml_last_return_address))(%r1) - ldw -8(%r30), %r31 - LOADHIGH(G(caml_gc_regs)) - stw %r31, LOW(G(caml_gc_regs))(%r1) - ldo -16(%r30), %r30 -; Save allocation pointer - LOADHIGH(G(caml_young_ptr)) - stw %r3, LOW(G(caml_young_ptr))(%r1) -; Move result where C function expects it - copy %r26, %r28 -; Reload callee-save registers - ldo -32(%r30), %r1 - ldws,ma -4(%r1), %r3 - ldws,ma -4(%r1), %r4 - ldws,ma -4(%r1), %r5 - ldws,ma -4(%r1), %r6 - ldws,ma -4(%r1), %r7 - ldws,ma -4(%r1), %r8 - ldws,ma -4(%r1), %r9 - ldws,ma -4(%r1), %r10 - ldws,ma -4(%r1), %r11 - ldws,ma -4(%r1), %r12 - ldws,ma -4(%r1), %r13 - ldws,ma -4(%r1), %r14 - ldws,ma -4(%r1), %r15 - ldws,ma -4(%r1), %r16 - ldws,ma -4(%r1), %r17 - ldws,ma -4(%r1), %r18 - fldds,ma -8(%r1), %fr12 - fldds,ma -8(%r1), %fr13 - fldds,ma -8(%r1), %fr14 - fldds,ma -8(%r1), %fr15 - fldds,ma -8(%r1), %fr16 - fldds,ma -8(%r1), %fr17 - fldds,ma -8(%r1), %fr18 - fldds,ma -8(%r1), %fr19 - fldds,ma -8(%r1), %fr20 - fldds,ma -8(%r1), %fr21 - fldds,ma -8(%r1), %fr22 - fldds,ma -8(%r1), %fr23 - fldds,ma -8(%r1), %fr24 - fldds,ma -8(%r1), %fr25 - fldds,ma -8(%r1), %fr26 - fldds,ma -8(%r1), %fr27 - fldds,ma -8(%r1), %fr28 - fldds,ma -8(%r1), %fr29 - fldds,ma -8(%r1), %fr30 - fldds,ma -8(%r1), %fr31 -; Return to C - ldo -256(%r30), %r30 - ldw -20(%r30), %r2 - bv 0(%r2) - nop -; The trap handler -L103: -; Save exception pointer - LOADHIGH(G(caml_exception_pointer)) - stw %r5, LOW(G(caml_exception_pointer))(%r1) -; Encode exception bucket as an exception result and return it - ldi 2, %r1 - or %r26, %r1, %r26 -; Return it - b L105 - nop - -; Re-raise the exception through caml_raise, to clean up local C roots - ldo 64(%r30), %r30 - bl G(caml_raise), %r2 - nop - ENDPROC - -; Raise an exception from C - - .align CODE_ALIGN - EXPORT_CODE(G(caml_raise_exception)) -G(caml_raise_exception): - STARTPROC -; Cut the stack - LOADHIGH(G(caml_exception_pointer)) - ldw LOW(G(caml_exception_pointer))(%r1), %r30 -; Reload allocation registers - LOADHIGH(G(caml_young_ptr)) - ldw LOW(G(caml_young_ptr))(%r1), %r3 - LOADHIGH(G(caml_young_limit)) - ldo LOW(G(caml_young_limit))(%r1), %r4 -; Raise the exception - ldw -4(%r30), %r1 - ldw -8(%r30), %r5 - bv 0(%r1) - ldo -8(%r30), %r30 ; in delay slot - ENDPROC - -; Callbacks C -> ML - - .align CODE_ALIGN - EXPORT_CODE(G(caml_callback_exn)) -G(caml_callback_exn): - STARTPROC -; Initial shuffling of arguments - copy %r26, %r1 ; Closure - copy %r25, %r26 ; Argument - copy %r1, %r25 - b L102 - ldw 0(%r1), %r22 ; Code to call (in delay slot) - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_callback2_exn)) -G(caml_callback2_exn): - STARTPROC - copy %r26, %r1 ; Closure - copy %r25, %r26 ; First argument - copy %r24, %r25 ; Second argument - copy %r1, %r24 - LOADHIGH(G(caml_apply2)) - b L102 - ldo LOW(G(caml_apply2))(%r1), %r22 - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_callback3_exn)) -G(caml_callback3_exn): - STARTPROC - copy %r26, %r1 ; Closure - copy %r25, %r26 ; First argument - copy %r24, %r25 ; Second argument - copy %r23, %r24 ; Third argument - copy %r1, %r23 - LOADHIGH(G(caml_apply3)) - b L102 - ldo LOW(G(caml_apply3))(%r1), %r22 - ENDPROC - - .align CODE_ALIGN - EXPORT_CODE(G(caml_ml_array_bound_error)) -G(caml_ml_array_bound_error): - STARTPROC -; Load address of [caml_array_bound_error] in %r22 - ldil LR%caml_array_bound_error, %r22 - ldo RR%caml_array_bound_error(%r22), %r22 -; Reserve 48 bytes of stack space and jump to caml_c_call - b G(caml_c_call) - ldo 48(%r30), %r30 /* in delay slot */ - ENDPROC - - .data - EXPORT_DATA(G(caml_system__frametable)) -G(caml_system__frametable): - .long 1 /* one descriptor */ - .long L104 + 3 /* return address into callback */ - .short -1 /* negative frame size => use callback link */ - .short 0 /* no roots */ diff --git a/asmrun/i386.S b/asmrun/i386.S index 73ac4674..e9b8a93b 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -16,6 +16,8 @@ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ +#include "../config/m.h" + /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. Linux/BSD with a.out binaries and NextStep do. */ @@ -42,6 +44,16 @@ #define FUNCTION_ALIGN 2 #endif +#ifdef 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 + #if defined(PROFILING) #if defined(SYS_linux_elf) || defined(SYS_gnu) #define PROFILE_CAML \ @@ -81,6 +93,9 @@ /* Allocation */ .text + .globl G(caml_system__code_begin) +G(caml_system__code_begin): + .globl G(caml_call_gc) .globl G(caml_alloc1) .globl G(caml_alloc2) @@ -89,14 +104,22 @@ .align FUNCTION_ALIGN G(caml_call_gc): + CFI_STARTPROC PROFILE_CAML /* Record lowest stack address and return address */ movl 0(%esp), %eax movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) - /* Build array of registers, save it into caml_gc_regs */ LBL(105): +#if !defined(SYS_mingw) && !defined(SYS_cygwin) + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subl $16384, %esp + movl %eax, 0(%esp) + addl $16384, %esp +#endif + /* Build array of registers, save it into caml_gc_regs */ pushl %ebp pushl %edi pushl %esi @@ -104,6 +127,7 @@ LBL(105): pushl %ecx pushl %ebx pushl %eax + CFI_ADJUST(28) movl %esp, G(caml_gc_regs) /* MacOSX note: 16-alignment of stack preserved at this point */ /* Call the garbage collector */ @@ -116,8 +140,10 @@ LBL(105): popl %esi popl %edi popl %ebp + CFI_ADJUST(-28) /* Return to caller */ ret + CFI_ENDPROC .align FUNCTION_ALIGN G(caml_alloc1): @@ -200,7 +226,7 @@ LBL(103): popl %eax /* recover desired size */ jmp G(caml_allocN) -/* Call a C function from Caml */ +/* Call a C function from OCaml */ .globl G(caml_c_call) .align FUNCTION_ALIGN @@ -211,20 +237,29 @@ G(caml_c_call): movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) +#if !defined(SYS_mingw) && !defined(SYS_cygwin) + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subl $16384, %esp + movl %eax, 0(%esp) + addl $16384, %esp +#endif /* Call the function (address in %eax) */ jmp *%eax -/* Start the Caml program */ +/* Start the OCaml program */ .globl G(caml_start_program) .align FUNCTION_ALIGN G(caml_start_program): + CFI_STARTPROC PROFILE_C /* Save callee-save registers */ pushl %ebx pushl %esi pushl %edi pushl %ebp + CFI_ADJUST(16) /* Initial entry point is caml_program */ movl $ G(caml_program), %esi /* Common code for caml_start_program and caml_callback* */ @@ -238,8 +273,9 @@ LBL(106): pushl $ LBL(108) ALIGN_STACK(8) pushl G(caml_exception_pointer) + CFI_ADJUST(20) movl %esp, G(caml_exception_pointer) - /* Call the Caml code */ + /* Call the OCaml code */ call *%esi LBL(107): /* Pop the exception handler */ @@ -249,6 +285,7 @@ LBL(107): #else addl $4, %esp #endif + CFI_ADJUST(-8) LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack) @@ -266,8 +303,9 @@ LBL(108): /* Mark the bucket as an exception result and return it */ orl $2, %eax jmp LBL(109) + CFI_ENDPROC -/* Raise an exception from Caml */ +/* Raise an exception from OCaml */ .globl G(caml_raise_exn) .align FUNCTION_ALIGN @@ -322,7 +360,7 @@ LBL(111): UNDO_ALIGN_STACK(8) ret -/* Callback from C to Caml */ +/* Callback from C to OCaml */ .globl G(caml_callback_exn) .align FUNCTION_ALIGN @@ -396,6 +434,9 @@ G(caml_ml_array_bound_error): /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) + .globl G(caml_system__code_end) +G(caml_system__code_end): + .data .globl G(caml_system__frametable) G(caml_system__frametable): diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index 711449cf..7649a8a4 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -1,15 +1,15 @@ -;********************************************************************* -; -; Objective Caml -; -; 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. -; -;********************************************************************* +;*********************************************************************** +;* * +;* 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. * +;* * +;*********************************************************************** ; $Id$ @@ -134,7 +134,7 @@ L103: sub eax, _caml_young_ptr ; eax = - size pop eax ; recover desired size jmp _caml_allocN -; Call a C function from Caml +; Call a C function from OCaml PUBLIC _caml_c_call ALIGN 4 @@ -147,7 +147,7 @@ _caml_c_call: ; Call the function (address in %eax) jmp eax -; Start the Caml program +; Start the OCaml program PUBLIC _caml_start_program ALIGN 4 @@ -171,7 +171,7 @@ L106: push L108 push _caml_exception_pointer mov _caml_exception_pointer, esp - ; Call the Caml code + ; Call the OCaml code call esi L107: ; Pop the exception handler @@ -196,7 +196,7 @@ L108: or eax, 2 jmp L109 -; Raise an exception for Caml +; Raise an exception for OCaml PUBLIC _caml_raise_exn ALIGN 4 @@ -244,7 +244,7 @@ L111: pop _caml_exception_pointer ret -; Callback from C to Caml +; Callback from C to OCaml PUBLIC _caml_callback_exn ALIGN 4 diff --git a/asmrun/ia64.S b/asmrun/ia64.S deleted file mode 100644 index d4296fa4..00000000 --- a/asmrun/ia64.S +++ /dev/null @@ -1,523 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* 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$ */ - -/* Asm part of the runtime system, IA64 processor */ - -#undef BROKEN_POSTINCREMENT - -#define ADDRGLOBAL(reg,symb) \ - add reg = @ltoff(symb), gp;; ld8 reg = [reg] -#define LOADGLOBAL(reg,symb) \ - add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; ld8 reg = [r3] -#define STOREGLOBAL(reg,symb) \ - add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; st8 [r3] = reg - -#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 -#define LDFDOFF(a,b,d) ldfd a = [b], d -#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d -#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d - -#define SAVE2(a,b) ST8OFF(r2, a, 16); ST8OFF(r3, b, 16) -#define SAVE4(a,b,c,d) SAVE2(a,b);; SAVE2(c,d) -#define SAVE8(a,b,c,d,e,f,g,h) SAVE4(a,b,c,d);; SAVE4(e,f,g,h) - -#define LOAD2(a,b) LD8OFF(a, r2, 16); LD8OFF(b, r3, 16) -#define LOAD4(a,b,c,d) LOAD2(a,b);; LOAD2(c,d) -#define LOAD8(a,b,c,d,e,f,g,h) LOAD4(a,b,c,d);; LOAD4(e,f,g,h) - -#define FSAVE2(a,b) STFDOFF(r2, a, 16); STFDOFF(r3, b, 16) -#define FSAVE4(a,b,c,d) FSAVE2(a,b);; FSAVE2(c,d) -#define FSAVE8(a,b,c,d,e,f,g,h) FSAVE4(a,b,c,d);; FSAVE4(e,f,g,h) - -#define FLOAD2(a,b) LDFDOFF(a, r2, 16); LDFDOFF(b, r3, 16) -#define FLOAD4(a,b,c,d) FLOAD2(a,b);; FLOAD2(c,d) -#define FLOAD8(a,b,c,d,e,f,g,h) FLOAD4(a,b,c,d);; FLOAD4(e,f,g,h) - -#define FSPILL2(a,b) STFSPILLOFF(r2, a, 32); STFSPILLOFF(r3, b, 32) -#define FSPILL4(a,b,c,d) FSPILL2(a,b);; FSPILL2(c,d) -#define FSPILL8(a,b,c,d,e,f,g,h) FSPILL4(a,b,c,d);; FSPILL4(e,f,g,h) - -#define FFILL2(a,b) LDFFILLOFF(a, r2, 32); LDFFILLOFF(b, r3, 32) -#define FFILL4(a,b,c,d) FFILL2(a,b);; FFILL2(c,d) -#define FFILL8(a,b,c,d,e,f,g,h) FFILL4(a,b,c,d);; FFILL4(e,f,g,h) - -/* Allocation */ - .text - - .global caml_allocN# - .proc caml_allocN# - .align 16 - -/* caml_allocN: all code generator registers preserved, - gp preserved, r2 = requested size */ - -caml_allocN: - sub r4 = r4, r2 ;; - cmp.ltu p0, p6 = r4, r5 - (p6) br.ret.sptk b0 ;; - /* Fall through caml_call_gc */ - br.sptk.many caml_call_gc# - - .endp caml_allocN# - -/* caml_call_gc: all code generator registers preserved, - gp preserved, r2 = requested size */ - - .global caml_call_gc# - .proc caml_call_gc# - .align 16 -caml_call_gc: - /* Allocate stack frame */ - add sp = -(16 + 16 + 80*8 + 42*8), sp ;; - - /* Save requested size and GP on stack */ - add r3 = 16, sp ;; - ST8OFF(r3, r2, 8) ;; - st8 [r3] = gp - - /* Record lowest stack address, return address, GC regs */ - mov r2 = b0 ;; - STOREGLOBAL(r2, caml_last_return_address#) - add r2 = (16 + 16 + 80*8 + 42*8), sp ;; - STOREGLOBAL(r2, caml_bottom_of_stack#) - add r2 = (16 + 16), sp ;; - STOREGLOBAL(r2, caml_gc_regs#) - - /* Save all integer regs used by the code generator in the context */ -.L100: add r3 = 8, r2 ;; - SAVE4(r8,r9,r10,r11) ;; - SAVE8(r16,r17,r18,r19,r20,r21,r22,r23) ;; - SAVE8(r24,r25,r26,r27,r28,r29,r30,r31) ;; - SAVE8(r32,r33,r34,r35,r36,r37,r38,r39) ;; - SAVE8(r40,r41,r42,r43,r44,r45,r46,r47) ;; - SAVE8(r48,r49,r50,r51,r52,r53,r54,r55) ;; - SAVE8(r56,r57,r58,r59,r60,r61,r62,r63) ;; - SAVE8(r64,r65,r66,r67,r68,r69,r70,r71) ;; - SAVE8(r72,r73,r74,r75,r76,r77,r78,r79) ;; - SAVE8(r80,r81,r82,r83,r84,r85,r86,r87) ;; - SAVE4(r88,r89,r90,r91) ;; - - /* Save all floating-point registers not preserved by C */ - FSAVE2(f6,f7) ;; - FSAVE8(f8,f9,f10,f11,f12,f13,f14,f15) ;; - FSAVE8(f32,f33,f34,f35,f36,f37,f38,f39) ;; - FSAVE8(f40,f41,f42,f43,f44,f45,f46,f47) ;; - FSAVE8(f48,f49,f50,f51,f52,f53,f54,f55) ;; - FSAVE8(f56,f57,f58,f59,f60,f61,f62,f63) ;; - - /* Save current allocation pointer for debugging purposes */ - STOREGLOBAL(r4, caml_young_ptr#) - - /* Save trap pointer in case an exception is raised */ - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Call the garbage collector */ - br.call.sptk b0 = caml_garbage_collection# ;; - - /* Restore gp */ - add r3 = 24, sp ;; - ld8 gp = [r3] - - /* Restore all integer regs from GC context */ - add r2 = (16 + 16), sp ;; - add r3 = 8, r2 ;; - LOAD4(r8,r9,r10,r11) ;; - LOAD8(r16,r17,r18,r19,r20,r21,r22,r23) ;; - LOAD8(r24,r25,r26,r27,r28,r29,r30,r31) ;; - LOAD8(r32,r33,r34,r35,r36,r37,r38,r39) ;; - LOAD8(r40,r41,r42,r43,r44,r45,r46,r47) ;; - LOAD8(r48,r49,r50,r51,r52,r53,r54,r55) ;; - LOAD8(r56,r57,r58,r59,r60,r61,r62,r63) ;; - LOAD8(r64,r65,r66,r67,r68,r69,r70,r71) ;; - LOAD8(r72,r73,r74,r75,r76,r77,r78,r79) ;; - LOAD8(r80,r81,r82,r83,r84,r85,r86,r87) ;; - LOAD4(r88,r89,r90,r91) ;; - - /* Restore all floating-point registers not preserved by C */ - FLOAD2(f6,f7) ;; - FLOAD8(f8,f9,f10,f11,f12,f13,f14,f15) ;; - FLOAD8(f32,f33,f34,f35,f36,f37,f38,f39) ;; - FLOAD8(f40,f41,f42,f43,f44,f45,f46,f47) ;; - FLOAD8(f48,f49,f50,f51,f52,f53,f54,f55) ;; - FLOAD8(f56,f57,f58,f59,f60,f61,f62,f63) ;; - - /* Reload new allocation pointer and allocation limit */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - - /* Allocate space for the block */ - add r3 = 16, sp ;; - ld8 r2 = [r3] ;; - sub r4 = r4, r2 ;; - cmp.ltu p6, p0 = r4, r5 /* enough space? */ - (p6) br.cond.spnt .L100 ;; /* no: call GC again */ - - /* Reload return address and say that we are back into Caml code */ - ADDRGLOBAL(r3, caml_last_return_address#) ;; - ld8 r2 = [r3] - st8 [r3] = r0 ;; - - /* Return to caller */ - mov b0 = r2 - add sp = (16 + 16 + 80*8 + 42*8), sp ;; - br.ret.sptk b0 - - .endp caml_call_gc# - -/* Call a C function from Caml */ -/* Function to call is in r2 */ - - .global caml_c_call# - .proc caml_c_call# - .align 16 - -caml_c_call: - /* The Caml code that called us does not expect any - code-generator registers to be preserved */ - - /* Recover entry point from the function pointer in r2 */ - LD8OFF(r3, r2, 8) ;; - mov b6 = r3 - - /* Preserve gp in r7 */ - mov r7 = gp - - /* Record lowest stack address and return address */ - mov r14 = b0 - STOREGLOBAL(sp, caml_bottom_of_stack#) ;; - STOREGLOBAL(r14, caml_last_return_address#) - - /* Make the exception handler and alloc ptr available to the C code */ - STOREGLOBAL(r4, caml_young_ptr#) - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Recover gp from the function pointer in r2 */ - ld8 gp = [r2] - - /* Call the function */ - br.call.sptk b0 = b6 ;; - - /* Restore gp */ - mov gp = r7 ;; - - /* Reload alloc ptr and alloc limit */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - - /* Reload return address and say that we are back into Caml code */ - ADDRGLOBAL(r3, caml_last_return_address#) ;; - ld8 r2 = [r3] - st8 [r3] = r0 ;; - - /* Return to caller */ - mov b0 = r2 ;; - br.ret.sptk b0 - - .endp caml_c_call# - -/* Start the Caml program */ - - .global caml_start_program# - .proc caml_start_program# - .align 16 - -caml_start_program: - ADDRGLOBAL(r2, caml_program#) ;; - mov b6 = r2 - - /* Code shared with caml_callback* */ -.L103: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ - alloc r3 = ar.pfs, 0, 0, 64, 0 - add sp = -(56 * 8), sp ;; - - /* Save all callee-save registers on stack */ - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) /* 0 : ar.pfs */ - mov r3 = b0 ;; - ST8OFF(r2, r3, 8) ;; /* 1 : return address */ - ST8OFF(r2, gp, 8) /* 2 : gp */ - mov r3 = pr ;; - ST8OFF(r2, r3, 8) /* 3 : predicates */ - mov r3 = ar.fpsr ;; - ST8OFF(r2, r3, 8) /* 4 : ar.fpsr */ - mov r3 = ar.unat ;; - ST8OFF(r2, r3, 8) /* 5 : ar.unat */ - mov r3 = ar.lc ;; - ST8OFF(r2, r3, 8) /* 6 : ar.lc */ - mov r3 = b1 ;; - ST8OFF(r2, r3, 8) /* 7 - 11 : b1 - b5 */ - mov r3 = b2 ;; - ST8OFF(r2, r3, 8) - mov r3 = b3 ;; - ST8OFF(r2, r3, 8) - mov r3 = b4 ;; - ST8OFF(r2, r3, 8) - mov r3 = b5 ;; - ST8OFF(r2, r3, 8) ;; - - add r3 = 8, r2 ;; - SAVE4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */ - - add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */ - FSPILL4(f2,f3,f4,f5) ;; - FSPILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;; - FSPILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;; - - /* Set up a callback link on the stack. In addition to - the normal callback link contents (saved values of - caml_bottom_of_stack, caml_last_return_address and - caml_gc_regs), we also save there caml_saved_bsp - and caml_saved_rnat */ - add sp = -48, sp - LOADGLOBAL(r3, caml_bottom_of_stack#) - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_last_return_address#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_gc_regs#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_saved_bsp#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_saved_rnat#) ;; - ST8OFF(r2, r3, 8) - - /* Set up a trap frame to catch exceptions escaping the Caml code */ - mov r6 = sp - add sp = -16, sp ;; - LOADGLOBAL(r3, caml_exception_pointer#) - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) -.L110: mov r3 = ip ;; - add r3 = .L101 - .L110, r3 ;; - ST8OFF(r2, r3, 8) ;; - - /* Save ar.bsp, flush register window, and save ar.rnat */ - mov r2 = ar.bsp ;; - STOREGLOBAL(r2, caml_saved_bsp#) ;; - mov r14 = ar.rsc ;; - and r2 = ~0x3, r14;; /* set rsc.mode = 0 */ - mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */ - flushrs ;; /* must be first instr in group */ - mov r2 = ar.rnat ;; - STOREGLOBAL(r2, caml_saved_rnat#) - mov ar.rsc = r14 /* restore original RSE mode */ - - /* Reload allocation pointers */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - - /* We are back into Caml code */ - STOREGLOBAL(r0, caml_last_return_address#) - - /* Call the Caml code */ - br.call.sptk b0 = b6 ;; -.L102: - - /* Pop the trap frame, restoring caml_exception_pointer */ - add sp = 16, sp ;; - ld8 r2 = [sp] ;; - STOREGLOBAL(r2, caml_exception_pointer#) - -.L104: - /* Pop the callback link, restoring the global variables */ - add r14 = 16, sp ;; - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_bottom_of_stack#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_last_return_address#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_gc_regs#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_saved_bsp#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_saved_rnat#) - add sp = 48, sp - - /* Update allocation pointer */ - STOREGLOBAL(r4, caml_young_ptr#) - - /* Restore all callee-save registers from stack */ - add r2 = 16, sp ;; - LD8OFF(r3, r2, 8) ;; /* 0 : ar.pfs */ - mov ar.pfs = r3 - LD8OFF(r3, r2, 8) ;; /* 1 : return address */ - mov b0 = r3 - LD8OFF(gp, r2, 8) ;; /* 2 : gp */ - LD8OFF(r3, r2, 8) ;; /* 3 : predicates */ - mov pr = r3, -1 - LD8OFF(r3, r2, 8) ;; /* 4 : ar.fpsr */ - mov ar.fpsr = r3 - LD8OFF(r3, r2, 8) ;; /* 5 : ar.unat */ - mov ar.unat = r3 - LD8OFF(r3, r2, 8) ;; /* 6 : ar.lc */ - mov ar.lc = r3 - LD8OFF(r3, r2, 8) ;; /* 7 - 11 : b1 - b5 */ - mov b1 = r3 - LD8OFF(r3, r2, 8) ;; - mov b2 = r3 - LD8OFF(r3, r2, 8) ;; - mov b3 = r3 - LD8OFF(r3, r2, 8) ;; - mov b4 = r3 - LD8OFF(r3, r2, 8) ;; - mov b5 = r3 - - add r3 = 8, r2 ;; - LOAD4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */ - - add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */ - FFILL4(f2,f3,f4,f5) ;; - FFILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;; - FFILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;; - - /* Pop stack frame and return */ - add sp = (56 * 8), sp - br.ret.sptk.many b0 ;; - - /* The trap handler */ -.L101: - /* Save exception pointer */ - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Encode exception bucket as exception result */ - or r8 = 2, r8 - - /* Return it */ - br.sptk .L104 ;; - - .endp caml_start_program# - -/* Raise an exception from C */ - - .global caml_raise_exception# - .proc caml_raise_exception# - .align 16 -caml_raise_exception: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ - /* Since we don't return, don't bother saving the PFS */ - alloc r2 = ar.pfs, 0, 0, 64, 0 - - /* Move exn bucket where Caml expects it */ - mov r8 = r32 ;; - - /* Perform "context switch" as per the Software Conventions Guide, - chapter 10 */ - flushrs ;; /* flush dirty registers to stack */ - mov r14 = ar.rsc ;; - and r2 = ~0x3, r14;; /* set rsc.mode = 0 */ - dep r2 = r0, r2, 16, 4 ;; /* clear rsc.loadrs */ - mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */ - invala ;; /* Invalidate ALAT */ - LOADGLOBAL(r2, caml_saved_bsp#) ;; - mov ar.bspstore = r2 /* Restore ar.bspstore */ - LOADGLOBAL(r2, caml_saved_rnat#) ;; - mov ar.rnat = r2 /* Restore ar.rnat */ - mov ar.rsc = r14 ;; /* Restore original RSE mode */ - - /* Reload allocation pointers and exception pointer */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - LOADGLOBAL(r6, caml_exception_pointer#) - - /* Say that we're back into Caml */ - STOREGLOBAL(r0, caml_last_return_address#) - - /* Raise the exception proper */ - mov sp = r6 - add r2 = 8, r6 ;; - ld8 r6 = [r6] - ld8 r2 = [r2] ;; - mov b6 = r2 ;; - - /* Branch to handler. Must use a call so as to set up the - CFM and PFS correctly. */ - br.call.sptk.many b0 = b6 - - .endp caml_raise_exception - -/* Callbacks from C to Caml */ - - .global caml_callback_exn# - .proc caml_callback_exn# - .align 16 -caml_callback_exn: - /* Initial shuffling of arguments */ - ld8 r3 = [r32] /* code pointer */ - mov r2 = r32 - mov r32 = r33 ;; /* first arg */ - mov r33 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp caml_callback_exn# - - .global caml_callback2_exn# - .proc caml_callback2_exn# - .align 16 -caml_callback2_exn: - /* Initial shuffling of arguments */ - ADDRGLOBAL(r3, caml_apply2) /* code pointer */ - mov r2 = r32 - mov r32 = r33 /* first arg */ - mov r33 = r34 ;; /* second arg */ - mov r34 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp caml_callback2_exn# - - .global caml_callback3_exn# - .proc caml_callback3_exn# - .align 16 -caml_callback3_exn: - /* Initial shuffling of arguments */ - ADDRGLOBAL(r3, caml_apply3) /* code pointer */ - mov r2 = r32 - mov r32 = r33 /* first arg */ - mov r33 = r34 /* second arg */ - mov r34 = r35 ;; /* third arg */ - mov r35 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp caml_callback3_exn# - -/* Glue code to call [caml_array_bound_error] */ - - .global caml_ml_array_bound_error# - .proc caml_ml_array_bound_error# - .align 16 -caml_ml_array_bound_error: - ADDRGLOBAL(r2, @fptr(caml_array_bound_error#)) - br.sptk caml_c_call /* never returns */ - - .rodata - - .global caml_system__frametable# - .type caml_system__frametable#, @object - .size caml_system__frametable#, 8 -caml_system__frametable: - data8 1 /* one descriptor */ - data8 .L102 /* return address into callback */ - data2 -1 /* negative frame size => use callback link */ - data2 0 /* no roots here */ - .align 8 - -/* Global variables used by caml_raise_exception */ - - .common caml_saved_bsp#, 8, 8 - .common caml_saved_rnat#, 8, 8 diff --git a/asmrun/m68k.S b/asmrun/m68k.S deleted file mode 100644 index 559eacbe..00000000 --- a/asmrun/m68k.S +++ /dev/null @@ -1,244 +0,0 @@ -|*********************************************************************** -|* * -|* Objective Caml * -|* * -|* 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. * -|* * -|*********************************************************************** - -| $Id$ - -| Asm part of the runtime system, Motorola 68k processor - - .comm _caml_requested_size, 4 - -| Allocation - - .text - .globl _caml_call_gc - .globl _caml_alloc1 - .globl _caml_alloc2 - .globl _caml_alloc3 - .globl _caml_allocN - -_caml_call_gc: - | Save desired size - movel d5, _caml_requested_size - | Record lowest stack address and return address - movel a7@, _caml_last_return_address - movel a7, d5 - addql #4, d5 - movel d5, _caml_bottom_of_stack - | Record current allocation pointer (for debugging) - movel d6, _caml_young_ptr - | Save all regs used by the code generator - movel d4, a7@- - movel d3, a7@- - movel d2, a7@- - movel d1, a7@- - movel d0, a7@- - movel a6, a7@- - movel a5, a7@- - movel a4, a7@- - movel a3, a7@- - movel a2, a7@- - movel a1, a7@- - movel a0, a7@- - movel a7, _caml_gc_regs - fmovem fp0-fp7, a7@- - | Call the garbage collector - jbsr _caml_garbage_collection - | Restore all regs used by the code generator - fmovem a7@+, fp0-fp7 - movel a7@+, a0 - movel a7@+, a1 - movel a7@+, a2 - movel a7@+, a3 - movel a7@+, a4 - movel a7@+, a5 - movel a7@+, a6 - movel a7@+, d0 - movel a7@+, d1 - movel a7@+, d2 - movel a7@+, d3 - movel a7@+, d4 - | Reload allocation pointer and allocate block - movel _caml_young_ptr, d6 - subl _caml_requested_size, d6 - | Return to caller - rts - -_caml_alloc1: - subql #8, d6 - cmpl _caml_young_limit, d6 - bcs L100 - rts -L100: moveq #8, d5 - bra _caml_call_gc - -_caml_alloc2: - subl #12, d6 - cmpl _caml_young_limit, d6 - bcs L101 - rts -L101: moveq #12, d5 - bra _caml_call_gc - -_caml_alloc3: - subl #16, d6 - cmpl _caml_young_limit, d6 - bcs L102 - rts -L102: moveq #16, d5 - bra _caml_call_gc - -_caml_allocN: - subl d5, d6 - cmpl _caml_young_limit, d6 - bcs _caml_call_gc - rts - -| Call a C function from Caml - - .globl _caml_c_call - -_caml_c_call: - | Record lowest stack address and return address - movel a7@+, _caml_last_return_address - movel a7, _caml_bottom_of_stack - | Save allocation pointer and exception pointer - movel d6, _caml_young_ptr - movel d7, _caml_exception_pointer - | Call the function (address in a0) - jbsr a0@ - | Reload allocation pointer - movel _caml_young_ptr, d6 - | Return to caller - movel _caml_last_return_address, a1 - jmp a1@ - -| Start the Caml program - - .globl _caml_start_program - -_caml_start_program: - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial code point is caml_program - lea _caml_program, a5 - -| Code shared between caml_start_program and caml_callback* - -L106: - | Build a callback link - movel _caml_gc_regs, a7@- - movel _caml_last_return_address, a7@- - movel _caml_bottom_of_stack, a7@- - | Build an exception handler - pea L108 - movel _caml_exception_pointer, a7@- - movel a7, d7 - | Load allocation pointer - movel _caml_young_ptr, d6 - | Call the Caml code - jbsr a5@ -L107: - | Move result where C code expects it - movel a0, d0 - | Save allocation pointer - movel d6, _caml_young_ptr - | Pop the exception handler - movel a7@+, _caml_exception_pointer - addql #4, a7 -L109: - | Pop the callback link, restoring the global variables - | used by caml_c_call - movel a7@+, _caml_bottom_of_stack - movel a7@+, _caml_last_return_address - movel a7@+, _caml_gc_regs - | Restore callee-save registers and return - fmovem a7@+, fp2-fp7 - moveml a7@+, a2-a6/d2-d7 - unlk a6 - rts -L108: - | Exception handler - | Save allocation pointer and exception pointer - movel d6, _caml_young_ptr - movel d7, _caml_exception_pointer - | Encode exception bucket as an exception result - movel a0, d0 - orl #2, d0 - | Return it - bra L109 - -| Raise an exception from C - - .globl _caml_raise_exception -_caml_raise_exception: - movel a7@(4), a0 | exception bucket - movel _caml_young_ptr, d6 - movel _caml_exception_pointer, a7 - movel a7@+, d7 - rts - -| Callback from C to Caml - - .globl _caml_callback_exn -_caml_callback_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a1 | closure - movel a6@(12), a0 | argument - movel a1@(0), a5 | code pointer - bra L106 - - .globl _caml_callback2_exn -_caml_callback2_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a2 | closure - movel a6@(12), a0 | first argument - movel a6@(16), a1 | second argument - lea _caml_apply2, a5 | code pointer - bra L106 - - .globl _caml_callback3_exn -_caml_callback3_exn: - link a6, #0 - | Save callee-save registers - moveml a2-a6/d2-d7, a7@- - fmovem fp2-fp7, a7@- - | Initial loading of arguments - movel a6@(8), a3 | closure - movel a6@(12), a0 | first argument - movel a6@(16), a1 | second argument - movel a6@(20), a2 | third argument - lea _caml_apply3, a5 | code pointer - bra L106 - - .globl _caml_ml_array_bound_error -_caml_ml_array_bound_error: - | Load address of [caml_array_bound_error] in a0 and call it - lea _caml_array_bound_error, a0 - bra _caml_c_call - - .data - .globl _caml_system__frametable -_caml_system__frametable: - .long 1 | one descriptor - .long L107 | return address into callback - .word -1 | negative frame size => use callback link - .word 0 | no roots here diff --git a/asmrun/mips.s b/asmrun/mips.s deleted file mode 100644 index 03fd6234..00000000 --- a/asmrun/mips.s +++ /dev/null @@ -1,386 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* 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. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, Mips processor, IRIX n32 conventions */ - -/* Allocation */ - - .text - - .globl caml_call_gc - .ent caml_call_gc - -caml_call_gc: - /* Reserve stack space for registers and saved $gp */ - /* 32 * 8 = 0x100 for float regs - 22 * 4 = 0x58 for integer regs - 8 = 0x8 for saved $gp ====> 0x160 total */ - subu $sp, $sp, 0x160 - /* Reinit $gp */ - .cpsetup $25, 0x158, caml_call_gc - /* Record return address */ - sw $31, caml_last_return_address - /* Record lowest stack address */ - addu $24, $sp, 0x160 - sw $24, caml_bottom_of_stack - /* Save pointer to register array */ - addu $24, $sp, 0x100 - sw $24, caml_gc_regs - /* Save current allocation pointer for debugging purposes */ - sw $22, caml_young_ptr - /* Save the exception handler (if e.g. a sighandler raises) */ - sw $30, caml_exception_pointer - /* Save all regs used by the code generator on the stack */ - sw $2, 2 * 4($24) - sw $3, 3 * 4($24) - sw $4, 4 * 4($24) - sw $5, 5 * 4($24) - sw $6, 6 * 4($24) - sw $7, 7 * 4($24) - sw $8, 8 * 4($24) - sw $9, 9 * 4($24) - sw $10, 10 * 4($24) - sw $11, 11 * 4($24) - sw $12, 12 * 4($24) - sw $13, 13 * 4($24) - sw $14, 14 * 4($24) - sw $15, 15 * 4($24) - sw $16, 16 * 4($24) - sw $17, 17 * 4($24) - sw $18, 18 * 4($24) - sw $19, 19 * 4($24) - sw $20, 20 * 4($24) - sw $21, 21 * 4($24) - s.d $f0, 0 * 8($sp) - s.d $f1, 1 * 8($sp) - s.d $f2, 2 * 8($sp) - s.d $f3, 3 * 8($sp) - s.d $f4, 4 * 8($sp) - s.d $f5, 5 * 8($sp) - s.d $f6, 6 * 8($sp) - s.d $f7, 7 * 8($sp) - s.d $f8, 8 * 8($sp) - s.d $f9, 9 * 8($sp) - s.d $f10, 10 * 8($sp) - s.d $f11, 11 * 8($sp) - s.d $f12, 12 * 8($sp) - s.d $f13, 13 * 8($sp) - s.d $f14, 14 * 8($sp) - s.d $f15, 15 * 8($sp) - s.d $f16, 16 * 8($sp) - s.d $f17, 17 * 8($sp) - s.d $f18, 18 * 8($sp) - s.d $f19, 19 * 8($sp) - s.d $f20, 20 * 8($sp) - s.d $f21, 21 * 8($sp) - s.d $f22, 22 * 8($sp) - s.d $f23, 23 * 8($sp) - s.d $f24, 24 * 8($sp) - s.d $f25, 25 * 8($sp) - s.d $f26, 26 * 8($sp) - s.d $f27, 27 * 8($sp) - s.d $f28, 28 * 8($sp) - s.d $f29, 29 * 8($sp) - s.d $f30, 30 * 8($sp) - s.d $f31, 31 * 8($sp) - /* Call the garbage collector */ - jal caml_garbage_collection - /* Restore all regs used by the code generator */ - addu $24, $sp, 0x100 - lw $2, 2 * 4($24) - lw $3, 3 * 4($24) - lw $4, 4 * 4($24) - lw $5, 5 * 4($24) - lw $6, 6 * 4($24) - lw $7, 7 * 4($24) - lw $8, 8 * 4($24) - lw $9, 9 * 4($24) - lw $10, 10 * 4($24) - lw $11, 11 * 4($24) - lw $12, 12 * 4($24) - lw $13, 13 * 4($24) - lw $14, 14 * 4($24) - lw $15, 15 * 4($24) - lw $16, 16 * 4($24) - lw $17, 17 * 4($24) - lw $18, 18 * 4($24) - lw $19, 19 * 4($24) - lw $20, 20 * 4($24) - lw $21, 21 * 4($24) - l.d $f0, 0 * 8($sp) - l.d $f1, 1 * 8($sp) - l.d $f2, 2 * 8($sp) - l.d $f3, 3 * 8($sp) - l.d $f4, 4 * 8($sp) - l.d $f5, 5 * 8($sp) - l.d $f6, 6 * 8($sp) - l.d $f7, 7 * 8($sp) - l.d $f8, 8 * 8($sp) - l.d $f9, 9 * 8($sp) - l.d $f10, 10 * 8($sp) - l.d $f11, 11 * 8($sp) - l.d $f12, 12 * 8($sp) - l.d $f13, 13 * 8($sp) - l.d $f14, 14 * 8($sp) - l.d $f15, 15 * 8($sp) - l.d $f16, 16 * 8($sp) - l.d $f17, 17 * 8($sp) - l.d $f18, 18 * 8($sp) - l.d $f19, 19 * 8($sp) - l.d $f20, 20 * 8($sp) - l.d $f21, 21 * 8($sp) - l.d $f22, 22 * 8($sp) - l.d $f23, 23 * 8($sp) - l.d $f24, 24 * 8($sp) - l.d $f25, 25 * 8($sp) - l.d $f26, 26 * 8($sp) - l.d $f27, 27 * 8($sp) - l.d $f28, 28 * 8($sp) - l.d $f29, 29 * 8($sp) - l.d $f30, 30 * 8($sp) - l.d $f31, 31 * 8($sp) - /* Reload new allocation pointer and allocation limit */ - lw $22, caml_young_ptr - lw $23, caml_young_limit - /* Reload return address */ - lw $31, caml_last_return_address - /* Say that we are back into Caml code */ - sw $0, caml_last_return_address - /* Adjust return address to restart the allocation sequence */ - subu $31, $31, 16 - /* Return */ - .cpreturn - addu $sp, $sp, 0x160 - j $31 - - .end caml_call_gc - -/* Call a C function from Caml */ - - .globl caml_c_call - .ent caml_c_call - -caml_c_call: - /* Function to call is in $24 */ - /* Set up $gp, saving caller's $gp in callee-save register $19 */ - .cpsetup $25, $19, caml_c_call - /* Preload addresses of interesting global variables - in callee-save registers */ - la $16, caml_last_return_address - la $17, caml_young_ptr - /* Save return address, bottom of stack, alloc ptr, exn ptr */ - sw $31, 0($16) /* caml_last_return_address */ - sw $sp, caml_bottom_of_stack - sw $22, 0($17) /* caml_young_ptr */ - sw $30, caml_exception_pointer - /* Call C function */ - move $25, $24 - jal $24 - /* Reload return address, alloc ptr, alloc limit */ - lw $31, 0($16) /* caml_last_return_address */ - lw $22, 0($17) /* caml_young_ptr */ - lw $23, caml_young_limit /* caml_young_limit */ - /* Zero caml_last_return_address, indicating we're back in Caml code */ - sw $0, 0($16) /* caml_last_return_address */ - /* Restore $gp and return */ - move $gp, $19 - j $31 - .end caml_c_call - -/* Start the Caml program */ - - .globl caml_start_program - .globl stray_exn_handler - .ent caml_start_program -caml_start_program: - /* Reserve space for callee-save registers */ - subu $sp, $sp, 0x90 - /* Setup $gp */ - .cpsetup $25, 0x80, caml_start_program - /* Load in $24 the code address to call */ - la $24, caml_program - /* Code shared with caml_callback* */ -$103: - /* Save return address */ - sd $31, 0x88($sp) - /* Save all callee-save registers */ - sd $16, 0x0($sp) - sd $17, 0x8($sp) - sd $18, 0x10($sp) - sd $19, 0x18($sp) - sd $20, 0x20($sp) - sd $21, 0x28($sp) - sd $22, 0x30($sp) - sd $23, 0x38($sp) - sd $30, 0x40($sp) - s.d $f20, 0x48($sp) - s.d $f22, 0x50($sp) - s.d $f24, 0x58($sp) - s.d $f26, 0x60($sp) - s.d $f28, 0x68($sp) - s.d $f30, 0x70($sp) - /* Set up a callback link on the stack. */ - subu $sp, $sp, 16 - lw $2, caml_bottom_of_stack - sw $2, 0($sp) - lw $3, caml_last_return_address - sw $3, 4($sp) - lw $4, caml_gc_regs - sw $4, 8($sp) - /* Set up a trap frame to catch exceptions escaping the Caml code */ - subu $sp, $sp, 16 - lw $30, caml_exception_pointer - sw $30, 0($sp) - la $2, $105 - sw $2, 4($sp) - sw $gp, 8($sp) - move $30, $sp - /* Reload allocation pointers */ - lw $22, caml_young_ptr - lw $23, caml_young_limit - /* Say that we are back into Caml code */ - sw $0, caml_last_return_address - /* Call the Caml code */ - move $25, $24 - jal $24 -$104: - /* Pop the trap frame, restoring caml_exception_pointer */ - lw $24, 0($sp) - sw $24, caml_exception_pointer - addu $sp, $sp, 16 -$106: - /* Pop the callback link, restoring the global variables */ - lw $24, 0($sp) - sw $24, caml_bottom_of_stack - lw $25, 4($sp) - sw $25, caml_last_return_address - lw $24, 8($sp) - sw $24, caml_gc_regs - addu $sp, $sp, 16 - /* Update allocation pointer */ - sw $22, caml_young_ptr - /* Reload callee-save registers and return */ - ld $31, 0x88($sp) - ld $16, 0x0($sp) - ld $17, 0x8($sp) - ld $18, 0x10($sp) - ld $19, 0x18($sp) - ld $20, 0x20($sp) - ld $21, 0x28($sp) - ld $22, 0x30($sp) - ld $23, 0x38($sp) - ld $30, 0x40($sp) - l.d $f20, 0x48($sp) - l.d $f22, 0x50($sp) - l.d $f24, 0x58($sp) - l.d $f26, 0x60($sp) - l.d $f28, 0x68($sp) - l.d $f30, 0x70($sp) - .cpreturn - addu $sp, $sp, 0x90 - j $31 - - /* The trap handler: encode exception bucket as an exception result - and return it */ -$105: - sw $30, caml_exception_pointer - or $2, $2, 2 - b $106 - - .end caml_start_program - -/* Raise an exception from C */ - - .globl caml_raise_exception - .ent caml_raise_exception -caml_raise_exception: - /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, caml_raise_exception - /* Branch to exn handler */ - move $2, $4 - lw $22, caml_young_ptr - lw $23, caml_young_limit - lw $sp, caml_exception_pointer - lw $30, 0($sp) - lw $24, 4($sp) - lw $gp, 8($sp) - addu $sp, $sp, 16 - j $24 - - .end caml_raise_exception - -/* Callback from C to Caml */ - - .globl caml_callback_exn - .ent caml_callback_exn -caml_callback_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, caml_callback_exn - /* Initial shuffling of arguments */ - move $9, $4 /* closure */ - move $8, $5 /* argument */ - lw $24, 0($4) /* code pointer */ - b $103 - .end caml_callback_exn - - .globl caml_callback2_exn - .ent caml_callback2_exn -caml_callback2_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, caml_callback2_exn - /* Initial shuffling of arguments */ - move $10, $4 /* closure */ - move $8, $5 /* first argument */ - move $9, $6 /* second argument */ - la $24, caml_apply2 /* code pointer */ - b $103 - - .end caml_callback2_exn - - .globl caml_callback3_exn - .ent caml_callback3_exn -caml_callback3_exn: - subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, caml_callback3_exn - /* Initial shuffling of arguments */ - move $11, $4 /* closure */ - move $8, $5 /* first argument */ - move $9, $6 /* second argument */ - move $10, $7 /* third argument */ - la $24, caml_apply3 /* code pointer */ - b $103 - - .end caml_callback3_exn - -/* Glue code to call [caml_array_bound_error] */ - - .globl caml_ml_array_bound_error - .ent caml_ml_array_bound_error - -caml_ml_array_bound_error: - /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, caml_ml_array_bound_error - la $24, caml_array_bound_error - jal caml_c_call /* never returns */ - - .end caml_ml_array_bound_error - - .rdata - .globl caml_system__frametable -caml_system__frametable: - .word 1 /* one descriptor */ - .word $104 /* return address into callback */ - .half -1 /* negative frame size => use callback link */ - .half 0 /* no roots here */ diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index 84cfb590..8625c545 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -1,9 +1,23 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Alain Frisch, 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 GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + #include "misc.h" #include "mlvalues.h" #include "memory.h" #include "stack.h" #include "callback.h" #include "alloc.h" +#include "intext.h" #include "natdynlink.h" #include "osdeps.h" #include "fail.h" @@ -61,6 +75,7 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) { CAMLparam1 (symbol); CAMLlocal1 (result); void *sym,*sym2; + struct code_fragment * cf; #define optsym(n) getsym(handle,unit,n) char *unit; @@ -81,8 +96,14 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) { sym = optsym("__code_begin"); sym2 = optsym("__code_end"); - if (NULL != sym && NULL != sym2) + if (NULL != sym && NULL != sym2) { caml_page_table_add(In_code_area, sym, sym2); + cf = caml_stat_alloc(sizeof(struct code_fragment)); + cf->code_start = (char *) sym; + cf->code_end = (char *) sym2; + cf->digest_computed = 0; + caml_ext_table_add(&caml_code_fragments_table, cf); + } entrypoint = optsym("__entry"); if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0); diff --git a/asmrun/power-aix.S b/asmrun/power-aix.S deleted file mode 100644 index d63cdae8..00000000 --- a/asmrun/power-aix.S +++ /dev/null @@ -1,513 +0,0 @@ -#********************************************************************* -#* * -#* Objective Caml * -#* * -#* 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. * -#* * -#********************************************************************* - -# $Id$ - - .csect .text[PR] - -#### Invoke the garbage collector. r0 contains the return address - - .globl .caml_call_gc -.caml_call_gc: - # Set up stack frame - stwu 1, -0x1C0(1) - # 0x1C0 = 4*32 (int regs) + 8*32 (float regs) + 64 (space for C call) - # Record last return address into Caml code - lwz 11, L..caml_last_return_address(2) - stw 0, 0(11) - # Record return address into call_gc stub code - mflr 0 - stw 0, 0x1C0+8(1) - # Record lowest stack address - lwz 11, L..caml_bottom_of_stack(2) - addi 0, 1, 0x1C0 - stw 0, 0(11) - # Record pointer to register array - lwz 11, L..caml_gc_regs(2) - addi 0, 1, 8*32 + 64 - stw 0, 0(11) - # Save current allocation pointer for debugging purposes - lwz 11, L..caml_young_ptr(2) - stw 31, 0(11) - # Save exception pointer (if e.g. a sighandler raises) - lwz 11, L..caml_exception_pointer(2) - stw 29, 0(11) - # Save all registers used by the code generator - addi 11, 1, 8*32 + 64 - 4 - stwu 3, 4(11) - stwu 4, 4(11) - stwu 5, 4(11) - stwu 6, 4(11) - stwu 7, 4(11) - stwu 8, 4(11) - stwu 9, 4(11) - stwu 10, 4(11) - stwu 14, 4(11) - stwu 15, 4(11) - stwu 16, 4(11) - stwu 17, 4(11) - stwu 18, 4(11) - stwu 19, 4(11) - stwu 20, 4(11) - stwu 21, 4(11) - stwu 22, 4(11) - stwu 23, 4(11) - stwu 24, 4(11) - stwu 25, 4(11) - stwu 26, 4(11) - stwu 27, 4(11) - stwu 28, 4(11) - addi 11, 1, 64 - 8 - stfdu 1, 8(11) - stfdu 2, 8(11) - stfdu 3, 8(11) - stfdu 4, 8(11) - stfdu 5, 8(11) - stfdu 6, 8(11) - stfdu 7, 8(11) - stfdu 8, 8(11) - stfdu 9, 8(11) - stfdu 10, 8(11) - stfdu 11, 8(11) - stfdu 12, 8(11) - stfdu 13, 8(11) - stfdu 14, 8(11) - stfdu 15, 8(11) - stfdu 16, 8(11) - stfdu 17, 8(11) - stfdu 18, 8(11) - stfdu 19, 8(11) - stfdu 20, 8(11) - stfdu 21, 8(11) - stfdu 22, 8(11) - stfdu 23, 8(11) - stfdu 24, 8(11) - stfdu 25, 8(11) - stfdu 26, 8(11) - stfdu 27, 8(11) - stfdu 28, 8(11) - stfdu 29, 8(11) - stfdu 30, 8(11) - stfdu 31, 8(11) - # Call the GC - bl .caml_garbage_collection - or 0, 0, 0 - # Reload new allocation pointer and allocation limit - lwz 11, L..caml_young_ptr(2) - lwz 31, 0(11) - lwz 11, L..caml_young_limit(2) - lwz 30, 0(11) - # Restore all regs used by the code generator - addi 11, 1, 8*32 + 64 - 4 - lwzu 3, 4(11) - lwzu 4, 4(11) - lwzu 5, 4(11) - lwzu 6, 4(11) - lwzu 7, 4(11) - lwzu 8, 4(11) - lwzu 9, 4(11) - lwzu 10, 4(11) - lwzu 14, 4(11) - lwzu 15, 4(11) - lwzu 16, 4(11) - lwzu 17, 4(11) - lwzu 18, 4(11) - lwzu 19, 4(11) - lwzu 20, 4(11) - lwzu 21, 4(11) - lwzu 22, 4(11) - lwzu 23, 4(11) - lwzu 24, 4(11) - lwzu 25, 4(11) - lwzu 26, 4(11) - lwzu 27, 4(11) - lwzu 28, 4(11) - addi 11, 1, 64 - 8 - lfdu 1, 8(11) - lfdu 2, 8(11) - lfdu 3, 8(11) - lfdu 4, 8(11) - lfdu 5, 8(11) - lfdu 6, 8(11) - lfdu 7, 8(11) - lfdu 8, 8(11) - lfdu 9, 8(11) - lfdu 10, 8(11) - lfdu 11, 8(11) - lfdu 12, 8(11) - lfdu 13, 8(11) - lfdu 14, 8(11) - lfdu 15, 8(11) - lfdu 16, 8(11) - lfdu 17, 8(11) - lfdu 18, 8(11) - lfdu 19, 8(11) - lfdu 20, 8(11) - lfdu 21, 8(11) - lfdu 22, 8(11) - lfdu 23, 8(11) - lfdu 24, 8(11) - lfdu 25, 8(11) - lfdu 26, 8(11) - lfdu 27, 8(11) - lfdu 28, 8(11) - lfdu 29, 8(11) - lfdu 30, 8(11) - lfdu 31, 8(11) - # Return to caller (the stub code), leaving return address into - # Caml code in the link register - lwz 0, 0x1C0+8(1) - mtctr 0 - lwz 11, L..caml_last_return_address(2) - lwz 0, 0(11) - addic 0, 0, -16 # Restart the allocation (4 instructions) - mtlr 0 - # Say we are back into Caml code - li 12, 0 - stw 12, 0(11) # 11 still points to caml_last_return_address - # Deallocate stack frame - addi 1, 1, 0x1C0 - # Return - bctr - -#### Call a C function from Caml - - .globl .caml_c_call -.caml_c_call: - # Save return address in 25 - mflr 25 - # Record lowest stack address and return address - lwz 27, L..caml_bottom_of_stack(2) - lwz 24, L..caml_last_return_address(2) - stw 1, 0(27) - stw 25, 0(24) - # Make the exception handler and alloc ptr available to the C code - lwz 27, L..caml_young_ptr(2) - lwz 26, L..caml_exception_pointer(2) - stw 31, 0(27) - stw 29, 0(26) - # Preserve RTOC and return address in callee-save registers - # The C function will preserve them, and the Caml code does not - # expect them to be preserved - # Return address is in 25, RTOC is in 26, pointer to caml_young_ptr in 27, - # pointer to caml_last_return_address is in 24 - # Call the function (descriptor in 11) - lwz 0, 0(11) - mr 26, 2 - mtlr 0 - lwz 2, 4(11) - lwz 11, 8(11) - blrl - # Restore return address - mtlr 25 - # Restore RTOC - mr 2, 26 - # Reload allocation pointer - lwz 31, 0(27) # 27 still points to caml_young_ptr - # Say we are back into Caml code - li 12, 0 - stw 12, 0(24) # 24 still points to caml_last_return_address - # Return to caller - blr - -#### Raise an exception from C - - .globl .caml_raise_exception -.caml_raise_exception: - # Reload Caml global registers - lwz 4, L..caml_exception_pointer(2) - lwz 5, L..caml_young_ptr(2) - lwz 6, L..caml_young_limit(2) - lwz 1, 0(4) - lwz 31, 0(5) - lwz 30, 0(6) - # Say we are back into Caml code - lwz 4, L..caml_last_return_address(2) - li 0, 0 - stw 0, 0(4) - # Pop trap frame - lwz 0, 0(1) - lwz 29, 4(1) - mtlr 0 - lwz 2, 20(1) - addi 1, 1, 32 - # Branch to handler - blr - -#### Start the Caml program - - .globl .caml_start_program -.caml_start_program: - lwz 11, L..caml_program(2) - -#### Code shared between caml_start_program and caml_callback* - -L..102: - mflr 0 - # Save return address - stw 0, 8(1) - # Save all callee-save registers - stw 13, -76(1) - stw 14, -72(1) - stw 15, -68(1) - stw 16, -64(1) - stw 17, -60(1) - stw 18, -56(1) - stw 19, -52(1) - stw 20, -48(1) - stw 21, -44(1) - stw 22, -40(1) - stw 23, -36(1) - stw 24, -32(1) - stw 25, -28(1) - stw 26, -24(1) - stw 27, -20(1) - stw 28, -16(1) - stw 29, -12(1) - stw 30, -8(1) - stw 31, -4(1) - stfd 14, -224(1) - stfd 15, -216(1) - stfd 16, -208(1) - stfd 17, -200(1) - stfd 18, -192(1) - stfd 19, -184(1) - stfd 20, -176(1) - stfd 21, -168(1) - stfd 22, -160(1) - stfd 23, -152(1) - stfd 24, -144(1) - stfd 25, -136(1) - stfd 26, -128(1) - stfd 27, -120(1) - stfd 28, -112(1) - stfd 29, -104(1) - stfd 30, -96(1) - stfd 31, -88(1) - # Allocate and link stack frame - stwu 1, -288(1) - # Set up a callback link - addi 1, 1, -32 - lwz 9, L..caml_bottom_of_stack(2) - lwz 10, L..caml_last_return_address(2) - lwz 12, L..caml_gc_regs(2) - lwz 9, 0(9) - lwz 10, 0(10) - lwz 12, 0(12) - stw 9, 0(1) - stw 10, 4(1) - stw 12, 8(1) - # Build an exception handler to catch exceptions escaping out of Caml - bl L..103 - b L..104 -L..103: - addi 1, 1, -32 - lwz 9, L..caml_exception_pointer(2) - mflr 0 - lwz 29, 0(9) - stw 0, 0(1) - stw 29, 4(1) - stw 2, 20(1) - mr 29, 1 - # Reload allocation pointers - lwz 9, L..caml_young_ptr(2) - lwz 10, L..caml_young_limit(2) - lwz 31, 0(9) - lwz 30, 0(10) - # Say we are back into Caml code - lwz 9, L..caml_last_return_address(2) - li 0, 0 - stw 0, 0(9) - # Call the Caml code - lwz 0, 0(11) - stw 2, 20(1) - mtlr 0 - lwz 2, 4(11) -L..105: - blrl - lwz 2, 20(1) - # Pop the trap frame, restoring caml_exception_pointer - lwz 9, 4(1) - lwz 10, L..caml_exception_pointer(2) - addi 1, 1, 32 - stw 9, 0(10) - # Pop the callback link, restoring the global variables -L..106: - lwz 7, 0(1) - lwz 8, 4(1) - lwz 9, 8(1) - lwz 10, L..caml_bottom_of_stack(2) - lwz 11, L..caml_last_return_address(2) - lwz 12, L..caml_gc_regs(2) - stw 7, 0(10) - stw 8, 0(11) - stw 9, 0(12) - addi 1, 1, 32 - # Update allocation pointer - lwz 11, L..caml_young_ptr(2) - stw 31, 0(11) - # Deallocate stack frame - addi 1, 1, 288 - # Restore callee-save registers - lwz 13, -76(1) - lwz 14, -72(1) - lwz 15, -68(1) - lwz 16, -64(1) - lwz 17, -60(1) - lwz 18, -56(1) - lwz 19, -52(1) - lwz 20, -48(1) - lwz 21, -44(1) - lwz 22, -40(1) - lwz 23, -36(1) - lwz 24, -32(1) - lwz 25, -28(1) - lwz 26, -24(1) - lwz 27, -20(1) - lwz 28, -16(1) - lwz 29, -12(1) - lwz 30, -8(1) - lwz 31, -4(1) - lfd 14, -224(1) - lfd 15, -216(1) - lfd 16, -208(1) - lfd 17, -200(1) - lfd 18, -192(1) - lfd 19, -184(1) - lfd 20, -176(1) - lfd 21, -168(1) - lfd 22, -160(1) - lfd 23, -152(1) - lfd 24, -144(1) - lfd 25, -136(1) - lfd 26, -128(1) - lfd 27, -120(1) - lfd 28, -112(1) - lfd 29, -104(1) - lfd 30, -96(1) - lfd 31, -88(1) - # Reload return address - lwz 0, 8(1) - mtlr 0 - # Return - blr - # The trap handler: -L..104: - # Update caml_exception_pointer - lwz 9, L..caml_exception_pointer(2) - stw 29, 0(9) - # Encode exception bucket as an exception result and return it - ori 3, 3, 2 - b L..106 - -#### Callback from C to Caml - - .globl .caml_callback_exn -.caml_callback_exn: - # Initial shuffling of arguments - mr 0, 3 # Closure - mr 3, 4 # Argument - mr 4, 0 - lwz 11, 0(4) # Code pointer - b L..102 - - .globl .caml_callback2_exn -.caml_callback2_exn: - mr 0, 3 # Closure - mr 3, 4 # First argument - mr 4, 5 # Second argument - mr 5, 0 - lwz 11, L..caml_apply2(2) - b L..102 - - .globl .caml_callback3_exn -.caml_callback3_exn: - mr 0, 3 # Closure - mr 3, 4 # First argument - mr 4, 5 # Second argument - mr 5, 6 # Third argument - mr 6, 0 - lwz 11, L..caml_apply3(2) - b L..102 - -#### Frame table - - .csect .data[RW] - .globl caml_system__frametable -caml_system__frametable: - .long 1 # one descriptor - .long L..105 + 4 # return address into callback - .short -1 # negative size count => use callback link - .short 0 # no roots here - -#### TOC entries - - .toc -L..caml_young_limit: - .tc caml_young_limit[TC], caml_young_limit -L..caml_young_ptr: - .tc caml_young_ptr[TC], caml_young_ptr -L..caml_bottom_of_stack: - .tc caml_bottom_of_stack[TC], caml_bottom_of_stack -L..caml_last_return_address: - .tc caml_last_return_address[TC], caml_last_return_address -L..caml_gc_regs: - .tc caml_gc_regs[TC], caml_gc_regs -L..caml_exception_pointer: - .tc caml_exception_pointer[TC], caml_exception_pointer -L..gc_entry_regs: - .tc gc_entry_regs[TC], gc_entry_regs -L..gc_entry_float_regs: - .tc gc_entry_float_regs[TC], gc_entry_float_regs -L..caml_program: - .tc caml_program[TC], caml_program -L..caml_apply2: - .tc caml_apply2[TC], caml_apply2 -L..caml_apply3: - .tc caml_apply3[TC], caml_apply3 - -#### Function closures - - .csect caml_call_gc[DS] -caml_call_gc: - .long .caml_call_gc, TOC[tc0], 0 - - .globl caml_c_call - .csect caml_c_call[DS] -caml_c_call: - .long .caml_c_call, TOC[tc0], 0 - - .globl caml_raise_exception - .csect caml_raise_exception[DS] -caml_raise_exception: - .long .caml_raise_exception, TOC[tc0], 0 - - .globl caml_start_program - .csect caml_start_program[DS] -caml_start_program: - .long .caml_start_program, TOC[tc0], 0 - - .globl caml_callback_exn - .csect caml_callback_exn[DS] -caml_callback_exn: - .long .caml_callback_exn, TOC[tc0], 0 - - .globl caml_callback2_exn - .csect caml_callback2_exn[DS] -caml_callback2_exn: - .long .caml_callback2_exn, TOC[tc0], 0 - - .globl caml_callback3_exn - .csect caml_callback3_exn[DS] -caml_callback3_exn: - .long .caml_callback3_exn, TOC[tc0], 0 diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index 968e3aeb..8618b50a 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -1,15 +1,15 @@ -/*********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* 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. */ -/* */ -/*********************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -27,13 +27,16 @@ /* Invoke the garbage collector. */ + .globl caml_system__code_begin +caml_system__code_begin: + .globl caml_call_gc .type caml_call_gc, @function caml_call_gc: /* Set up stack frame */ stwu 1, -0x1A0(1) /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ - /* Record return address into Caml code */ + /* Record return address into OCaml code */ mflr 0 Storeglobal(0, caml_last_return_address, 11) /* Record lowest stack address */ @@ -169,7 +172,7 @@ caml_call_gc: Loadglobal(0, caml_last_return_address, 11) addic 0, 0, -16 /* Restart the allocation (4 instructions) */ mtlr 0 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) /* Deallocate stack frame */ @@ -177,7 +180,7 @@ caml_call_gc: /* Return */ blr -/* Call a C function from Caml */ +/* Call a C function from OCaml */ .globl caml_c_call .type caml_c_call, @function @@ -185,21 +188,21 @@ caml_c_call: /* Save return address */ mflr 25 /* Get ready to call C function (address in 11) */ - mtlr 11 + mtctr 11 /* Record lowest stack address and return address */ Storeglobal(1, caml_bottom_of_stack, 12) Storeglobal(25, caml_last_return_address, 12) /* Make the exception handler and alloc ptr available to the C code */ Storeglobal(31, caml_young_ptr, 11) Storeglobal(29, caml_exception_pointer, 11) - /* Call the function (address in link register) */ - blrl + /* Call the function (address in CTR register) */ + bctrl /* Restore return address (in 25, preserved by the C function) */ mtlr 25 /* Reload allocation pointer and allocation limit*/ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) /* Return to caller */ @@ -210,11 +213,11 @@ caml_c_call: .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: - /* Reload Caml global registers */ + /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) /* Pop trap frame */ @@ -225,7 +228,7 @@ caml_raise_exception: /* Branch to handler */ blr -/* Start the Caml program */ +/* Start the OCaml program */ .globl caml_start_program .type caml_start_program, @function @@ -287,7 +290,7 @@ caml_start_program: stw 9, 0(1) stw 10, 4(1) stw 11, 8(1) - /* Build an exception handler to catch exceptions escaping out of Caml */ + /* Build an exception handler to catch exceptions escaping out of OCaml */ bl .L103 b .L104 .L103: @@ -300,10 +303,10 @@ caml_start_program: /* Reload allocation pointers */ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) - /* Call the Caml code */ + /* Call the OCaml code */ mtlr 12 .L105: blrl @@ -375,7 +378,7 @@ caml_start_program: ori 3, 3, 2 b .L106 -/* Callback from C to Caml */ +/* Callback from C to OCaml */ .globl caml_callback_exn .type caml_callback_exn, @function @@ -408,6 +411,9 @@ caml_callback3_exn: Addrglobal(12, caml_apply3) b .L102 + .globl caml_system__code_end +caml_system__code_end: + /* Frame table */ .section ".data" diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index 765de9c8..843e056a 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -1,15 +1,15 @@ -/*********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* 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. */ -/* */ -/*********************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -41,6 +41,9 @@ .text + .globl _caml_system__code_begin +_caml_system__code_begin: + /* Invoke the garbage collector. */ .globl _caml_call_gc @@ -48,12 +51,17 @@ _caml_call_gc: /* Set up stack frame */ #define FRAMESIZE (32*WORD + 32*8 + 32) stwu r1, -FRAMESIZE(r1) - /* Record return address into Caml code */ + /* Record return address into OCaml code */ mflr r0 Storeglobal r0, _caml_last_return_address, r11 /* Record lowest stack address */ addi r0, r1, FRAMESIZE Storeglobal r0, _caml_bottom_of_stack, r11 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + addi r1, r1, -4096*WORD + stg r0, 0(r1) + addi r1, r1, 4096*WORD /* Record pointer to register array */ addi r0, r1, 8*32 + 32 Storeglobal r0, _caml_gc_regs, r11 @@ -184,7 +192,7 @@ _caml_call_gc: Loadglobal r0, _caml_last_return_address, r11 addic r0, r0, -16 /* Restart the allocation (4 instructions) */ mtlr r0 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Deallocate stack frame */ @@ -193,7 +201,7 @@ _caml_call_gc: blr #undef FRAMESIZE -/* Call a C function from Caml */ +/* Call a C function from OCaml */ .globl _caml_c_call _caml_c_call: @@ -204,6 +212,11 @@ _caml_c_call: /* Record lowest stack address and return address */ Storeglobal r1, _caml_bottom_of_stack, r12 Storeglobal r25, _caml_last_return_address, r12 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + addi r1, r1, -4096*WORD + stg r0, 0(r1) + addi r1, r1, 4096*WORD /* Make the exception handler and alloc ptr available to the C code */ Storeglobal r31, _caml_young_ptr, r11 Storeglobal r29, _caml_exception_pointer, r11 @@ -214,13 +227,13 @@ _caml_c_call: /* Reload allocation pointer and allocation limit*/ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Return to caller */ blr -/* Raise an exception from Caml */ +/* Raise an exception from OCaml */ .globl _caml_raise_exn _caml_raise_exn: addis r11, 0, ha16(_caml_backtrace_active) @@ -257,11 +270,11 @@ _caml_raise_exception: cmpwi r11, 0 bne L112 L113: - /* Reload Caml global registers */ + /* Reload OCaml global registers */ Loadglobal r1, _caml_exception_pointer, r11 Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 /* Pop trap frame */ @@ -282,7 +295,7 @@ L112: mr r3, r28 b L113 -/* Start the Caml program */ +/* Start the OCaml program */ .globl _caml_start_program _caml_start_program: @@ -343,7 +356,7 @@ L102: stg r9, 0(r1) stg r10, WORD(r1) stg r11, 2*WORD(r1) - /* Build an exception handler to catch exceptions escaping out of Caml */ + /* Build an exception handler to catch exceptions escaping out of OCaml */ bl L103 b L104 L103: @@ -356,10 +369,10 @@ L103: /* Reload allocation pointers */ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 - /* Call the Caml code */ + /* Call the OCaml code */ mtctr r12 L105: bctrl @@ -432,7 +445,7 @@ L104: b L106 #undef FRAMESIZE -/* Callback from C to Caml */ +/* Callback from C to OCaml */ .globl _caml_callback_exn _caml_callback_exn: @@ -462,6 +475,9 @@ _caml_callback3_exn: Addrglobal r12, _caml_apply3 b L102 + .globl _caml_system__code_end +_caml_system__code_end: + /* Frame table */ .const diff --git a/asmrun/roots.c b/asmrun/roots.c index cb75a099..edb7429d 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -129,7 +129,7 @@ void caml_init_frame_descriptors(void) char * caml_top_of_stack; char * caml_bottom_of_stack = NULL; /* no stack initially */ -uintnat caml_last_return_address = 1; /* not in Caml code initially */ +uintnat caml_last_return_address = 1; /* not in OCaml code initially */ value * caml_gc_regs; intnat caml_globals_inited = 0; static intnat caml_globals_scanned = 0; diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index f8f542ad..9d42718b 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ /* */ @@ -46,14 +46,17 @@ extern void caml_win32_overflow_detection(); #endif extern char * caml_code_area_start, * caml_code_area_end; +extern char caml_system__code_begin, caml_system__code_end; #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ - || (Classify_addr(pc) & In_code_area) ) +|| ((char *)(pc) >= &caml_system__code_begin && \ + (char *)(pc) <= &caml_system__code_end) \ +|| (Classify_addr(pc) & In_code_area) ) /* This routine is the common entry point for garbage collection - and signal handling. It can trigger a callback to Caml code. + and signal handling. It can trigger a callback to OCaml code. With system threads, this callback can cause a context switch. Hence [caml_garbage_collection] must not be called from regular C code (e.g. the [caml_alloc] function) because the context of the call @@ -83,7 +86,7 @@ DECLARE_SIGNAL_HANDLER(handle_signal) caml_record_signal(sig); /* Some ports cache [caml_young_limit] in a register. Use the signal context to modify that register too, but only if - we are inside Caml code (not inside C code). */ + we are inside OCaml code (not inside C code). */ #if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT) if (Is_in_code_area(CONTEXT_PC)) CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; @@ -175,6 +178,15 @@ DECLARE_SIGNAL_HANDLER(trap_handler) static char * system_stack_top; static char sig_alt_stack[SIGSTKSZ]; +#if defined(SYS_linux) +/* PR#4746: recent Linux kernels with support for stack randomization + silently add 2 Mb of stack space on top of RLIMIT_STACK. + 2 Mb = 0x200000, to which we add 8 kB (=0x2000) for overshoot. */ +#define EXTRA_STACK 0x202000 +#else +#define EXTRA_STACK 0x2000 +#endif + DECLARE_SIGNAL_HANDLER(segv_handler) { struct rlimit limit; @@ -184,12 +196,12 @@ DECLARE_SIGNAL_HANDLER(segv_handler) /* Sanity checks: - faulting address is word-aligned - faulting address is within the stack - - we are in Caml code */ + - we are in OCaml code */ fault_addr = CONTEXT_FAULTING_ADDRESS; if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0 && getrlimit(RLIMIT_STACK, &limit) == 0 && fault_addr < system_stack_top - && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000 + && fault_addr >= system_stack_top - limit.rlim_cur - EXTRA_STACK #ifdef CONTEXT_PC && Is_in_code_area(CONTEXT_PC) #endif diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 76552e5e..830c43b3 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -15,26 +15,9 @@ /* Processor- and OS-dependent signal interface */ -/****************** Alpha, all OS */ - -#if defined(TARGET_alpha) - - #define DECLARE_SIGNAL_HANDLER(name) \ - static void name(int sig, int code, struct sigcontext * context) - - #define SET_SIGACT(sigact,name) \ - sigact.sa_handler = (void (*)(int)) (name); \ - sigact.sa_flags = 0 - - typedef long context_reg; - #define CONTEXT_PC (context->sc_pc) - #define CONTEXT_EXCEPTION_POINTER (context->sc_regs[15]) - #define CONTEXT_YOUNG_LIMIT (context->sc_regs[13]) - #define CONTEXT_YOUNG_PTR (context->sc_regs[14]) - /****************** AMD64, Linux */ -#elif defined(TARGET_amd64) && defined (SYS_linux) +#if defined(TARGET_amd64) && defined (SYS_linux) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) @@ -78,7 +61,7 @@ /****************** ARM, Linux */ -#elif defined(TARGET_arm) && defined (SYS_linux) +#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) || defined(SYS_linux_eabihf)) #include @@ -177,23 +160,6 @@ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) -/****************** MIPS, all OS */ - -#elif defined(TARGET_mips) - - #define DECLARE_SIGNAL_HANDLER(name) \ - static void name(int sig, int code, struct sigcontext * context) - - #define SET_SIGACT(sigact,name) \ - sigact.sa_handler = (void (*)(int)) (name); \ - sigact.sa_flags = 0 - - typedef int context_reg; - #define CONTEXT_PC (context->sc_pc) - #define CONTEXT_EXCEPTION_POINTER (context->sc_regs[30]) - #define CONTEXT_YOUNG_LIMIT (context->sc_regs[22]) - #define CONTEXT_YOUNG_PTR (context->sc_regs[23]) - /****************** PowerPC, MacOS X */ #elif defined(TARGET_power) && defined(SYS_rhapsody) diff --git a/asmrun/sparc.S b/asmrun/sparc.S index 38d0be0c..26174315 100644 --- a/asmrun/sparc.S +++ b/asmrun/sparc.S @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -16,60 +16,6 @@ /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ -/* SunOS 4 prefixes identifiers with _ */ - -#if defined(SYS_sunos) - -#define Caml_young_limit _caml_young_limit -#define Caml_young_ptr _caml_young_ptr -#define Caml_bottom_of_stack _caml_bottom_of_stack -#define Caml_last_return_address _caml_last_return_address -#define Caml_gc_regs _caml_gc_regs -#define Caml_exception_pointer _caml_exception_pointer -#define Caml_allocN _caml_allocN -#define Caml_call_gc _caml_call_gc -#define Caml_garbage_collection _caml_garbage_collection -#define Caml_c_call _caml_c_call -#define Caml_start_program _caml_start_program -#define Caml_program _caml_program -#define Caml_raise_exception _caml_raise_exception -#define Caml_callback_exn _caml_callback_exn -#define Caml_callback2_exn _caml_callback2_exn -#define Caml_callback3_exn _caml_callback3_exn -#define Caml_apply2 _caml_apply2 -#define Caml_apply3 _caml_apply3 -#define Caml_raise _caml_raise -#define Caml_system__frametable _caml_system__frametable -#define Caml_ml_array_bound_error _caml_ml_array_bound_error -#define Caml_array_bound_error _caml_array_bound_error - -#else - -#define Caml_young_limit caml_young_limit -#define Caml_young_ptr caml_young_ptr -#define Caml_bottom_of_stack caml_bottom_of_stack -#define Caml_last_return_address caml_last_return_address -#define Caml_gc_regs caml_gc_regs -#define Caml_exception_pointer caml_exception_pointer -#define Caml_allocN caml_allocN -#define Caml_call_gc caml_call_gc -#define Caml_garbage_collection caml_garbage_collection -#define Caml_c_call caml_c_call -#define Caml_start_program caml_start_program -#define Caml_program caml_program -#define Caml_raise_exception caml_raise_exception -#define Caml_callback_exn caml_callback_exn -#define Caml_callback2_exn caml_callback2_exn -#define Caml_callback3_exn caml_callback3_exn -#define Caml_apply2 caml_apply2 -#define Caml_apply3 caml_apply3 -#define Caml_raise caml_raise -#define Caml_system__frametable caml_system__frametable -#define Caml_ml_array_bound_error caml_ml_array_bound_error -#define Caml_array_bound_error caml_array_bound_error - -#endif - #ifndef SYS_solaris #define INDIRECT_LIMIT #endif @@ -85,11 +31,15 @@ /* Allocation functions */ .text - .global Caml_allocN - .global Caml_call_gc + + .global caml_system__code_begin +caml_system__code_begin: + + .global caml_allocN + .global caml_call_gc /* Required size in %g2 */ -Caml_allocN: +caml_allocN: #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr @@ -98,22 +48,22 @@ Caml_allocN: sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif - /*blu,pt %icc, Caml_call_gc*/ - blu Caml_call_gc + /*blu,pt %icc, caml_call_gc*/ + blu caml_call_gc nop retl nop /* Required size in %g2 */ -Caml_call_gc: +caml_call_gc: /* Save exception pointer if GC raises */ - Store(Exn_ptr, Caml_exception_pointer) + Store(Exn_ptr, caml_exception_pointer) /* Save current allocation pointer for debugging purposes */ - Store(Alloc_ptr, Caml_young_ptr) + Store(Alloc_ptr, caml_young_ptr) /* Record lowest stack address */ - Store(%sp, Caml_bottom_of_stack) + Store(%sp, caml_bottom_of_stack) /* Record last return address */ - Store(%o7, Caml_last_return_address) + Store(%o7, caml_last_return_address) /* Allocate space on stack for caml_context structure and float regs */ sub %sp, 20*4 + 15*8, %sp /* Save int regs on stack and save it into caml_gc_regs */ @@ -139,7 +89,7 @@ L100: add %sp, 96 + 15*8, %g1 st %g4, [%g1 + 0x48] st %g2, [%g1 + 0x4C] /* Save required size */ mov %g1, %g2 - Store(%g2, Caml_gc_regs) + Store(%g2, caml_gc_regs) /* Save the floating-point registers */ add %sp, 96, %g1 std %f0, [%g1] @@ -158,7 +108,7 @@ L100: add %sp, 96 + 15*8, %g1 std %f26, [%g1 + 0x68] std %f28, [%g1 + 0x70] /* Call the garbage collector */ - call Caml_garbage_collection + call caml_garbage_collection nop /* Restore all regs used by the code generator */ add %sp, 96 + 15*8, %g1 @@ -199,116 +149,116 @@ L100: add %sp, 96 + 15*8, %g1 ldd [%g1 + 0x68], %f26 ldd [%g1 + 0x70], %f28 /* Reload alloc ptr */ - Load(Caml_young_ptr, Alloc_ptr) + Load(caml_young_ptr, Alloc_ptr) /* Allocate space for block */ #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, %g1 /* Check that we have enough free space */ #else - Load(Caml_young_limit,Alloc_limit) + Load(caml_young_limit,Alloc_limit) sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif blu L100 /* If not, call GC again */ nop /* Return to caller */ - Load(Caml_last_return_address, %o7) + Load(caml_last_return_address, %o7) retl add %sp, 20*4 + 15*8, %sp /* in delay slot */ -/* Call a C function from Caml */ +/* Call a C function from Ocaml */ - .global Caml_c_call + .global caml_c_call /* Function to call is in %g2 */ -Caml_c_call: +caml_c_call: /* Record lowest stack address and return address */ - Store(%sp, Caml_bottom_of_stack) - Store(%o7, Caml_last_return_address) + Store(%sp, caml_bottom_of_stack) + Store(%o7, caml_last_return_address) /* Save the exception handler and alloc pointer */ - Store(Exn_ptr, Caml_exception_pointer) - sethi %hi(Caml_young_ptr), %g1 + Store(Exn_ptr, caml_exception_pointer) + sethi %hi(caml_young_ptr), %g1 /* Call the C function */ call %g2 - st Alloc_ptr, [%g1 + %lo(Caml_young_ptr)] /* in delay slot */ + st Alloc_ptr, [%g1 + %lo(caml_young_ptr)] /* in delay slot */ /* Reload return address */ - Load(Caml_last_return_address, %o7) + Load(caml_last_return_address, %o7) /* Reload alloc pointer */ - sethi %hi(Caml_young_ptr), %g1 + sethi %hi(caml_young_ptr), %g1 /* Return to caller */ retl - ld [%g1 + %lo(Caml_young_ptr)], Alloc_ptr /* in delay slot */ + ld [%g1 + %lo(caml_young_ptr)], Alloc_ptr /* in delay slot */ -/* Start the Caml program */ +/* Start the Ocaml program */ - .global Caml_start_program -Caml_start_program: + .global caml_start_program +caml_start_program: /* Save all callee-save registers */ save %sp, -96, %sp /* Address of code to call */ - Address(Caml_program, %l2) + Address(caml_program, %l2) /* Code shared with caml_callback* */ L108: /* Set up a callback link on the stack. */ sub %sp, 16, %sp - Load(Caml_bottom_of_stack, %l0) - Load(Caml_last_return_address, %l1) - Load(Caml_gc_regs, %l3) + Load(caml_bottom_of_stack, %l0) + Load(caml_last_return_address, %l1) + Load(caml_gc_regs, %l3) st %l0, [%sp + 96] st %l1, [%sp + 100] - /* Set up a trap frame to catch exceptions escaping the Caml code */ + /* Set up a trap frame to catch exceptions escaping the Ocaml code */ call L111 st %l3, [%sp + 104] b L110 nop L111: sub %sp, 8, %sp - Load(Caml_exception_pointer, Exn_ptr) + Load(caml_exception_pointer, Exn_ptr) st %o7, [%sp + 96] st Exn_ptr, [%sp + 100] mov %sp, Exn_ptr /* Reload allocation pointers */ - Load(Caml_young_ptr, Alloc_ptr) + Load(caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT - Address(Caml_young_limit, Alloc_limit) + Address(caml_young_limit, Alloc_limit) #else - Load(Caml_young_limit, Alloc_limit) + Load(caml_young_limit, Alloc_limit) #endif - /* Call the Caml code */ + /* Call the Ocaml code */ L109: call %l2 nop /* Pop trap frame and restore caml_exception_pointer */ ld [%sp + 100], Exn_ptr add %sp, 8, %sp - Store(Exn_ptr, Caml_exception_pointer) + Store(Exn_ptr, caml_exception_pointer) /* Pop callback link, restoring the global variables */ L112: ld [%sp + 96], %l0 ld [%sp + 100], %l1 ld [%sp + 104], %l2 - Store(%l0, Caml_bottom_of_stack) - Store(%l1, Caml_last_return_address) - Store(%l2, Caml_gc_regs) + Store(%l0, caml_bottom_of_stack) + Store(%l1, caml_last_return_address) + Store(%l2, caml_gc_regs) add %sp, 16, %sp /* Save allocation pointer */ - Store(Alloc_ptr, Caml_young_ptr) + Store(Alloc_ptr, caml_young_ptr) /* Reload callee-save registers and return */ ret restore %o0, 0, %o0 /* copy %o0 in this window to caller's %o0 */ L110: /* The trap handler */ - Store(Exn_ptr, Caml_exception_pointer) + Store(Exn_ptr, caml_exception_pointer) /* Encode exception bucket as an exception result */ b L112 or %o0, 2, %o0 /* Raise an exception from C */ - .global Caml_raise_exception -Caml_raise_exception: + .global caml_raise_exception +caml_raise_exception: /* Save exception bucket in a register outside the reg windows */ mov %o0, %g2 /* Load exception pointer in a register outside the reg windows */ - Load(Caml_exception_pointer, %g3) + Load(caml_exception_pointer, %g3) /* Pop some frames until the trap pointer is in the current frame. */ cmp %g3, %fp blt L107 /* if Exn_ptr < %fp, over */ @@ -319,11 +269,11 @@ L106: restore nop L107: /* Reload allocation registers */ - Load(Caml_young_ptr, Alloc_ptr) + Load(caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT - Address(Caml_young_limit, Alloc_limit) + Address(caml_young_limit, Alloc_limit) #else - Load(Caml_young_limit, Alloc_limit) + Load(caml_young_limit, Alloc_limit) #endif /* Branch to exception handler */ mov %g3, %sp @@ -336,8 +286,8 @@ L107: /* Callbacks C -> ML */ - .global Caml_callback_exn -Caml_callback_exn: + .global caml_callback_exn +caml_callback_exn: /* Save callee-save registers and return address */ save %sp, -96, %sp /* Initial shuffling of arguments */ @@ -347,8 +297,8 @@ Caml_callback_exn: b L108 ld [%g1], %l2 /* code pointer */ - .global Caml_callback2_exn -Caml_callback2_exn: + .global caml_callback2_exn +caml_callback2_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ @@ -356,12 +306,12 @@ Caml_callback2_exn: mov %i1, %i0 /* first arg */ mov %i2, %i1 /* second arg */ mov %g1, %i2 /* environment */ - sethi %hi(Caml_apply2), %l2 + sethi %hi(caml_apply2), %l2 b L108 - or %l2, %lo(Caml_apply2), %l2 + or %l2, %lo(caml_apply2), %l2 - .global Caml_callback3_exn -Caml_callback3_exn: + .global caml_callback3_exn +caml_callback3_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ @@ -370,38 +320,41 @@ Caml_callback3_exn: mov %i2, %i1 /* second arg */ mov %i3, %i2 /* third arg */ mov %g1, %i3 /* environment */ - sethi %hi(Caml_apply3), %l2 + sethi %hi(caml_apply3), %l2 b L108 - or %l2, %lo(Caml_apply3), %l2 + or %l2, %lo(caml_apply3), %l2 #ifndef SYS_solaris /* Glue code to call [caml_array_bound_error] */ - .global Caml_ml_array_bound_error -Caml_ml_array_bound_error: - Address(Caml_array_bound_error, %g2) - b Caml_c_call + .global caml_ml_array_bound_error +caml_ml_array_bound_error: + Address(caml_array_bound_error, %g2) + b caml_c_call nop #endif + .global caml_system__code_end +caml_system__code_end: + #ifdef SYS_solaris .section ".rodata" #else .data #endif - .global Caml_system__frametable + .global caml_system__frametable .align 4 /* required for gas? */ -Caml_system__frametable: +caml_system__frametable: .word 1 /* one descriptor */ .word L109 /* return address into callback */ .half -1 /* negative frame size => use callback link */ .half 0 /* no roots */ #ifdef SYS_solaris - .type Caml_allocN, #function - .type Caml_call_gc, #function - .type Caml_c_call, #function - .type Caml_start_program, #function - .type Caml_raise_exception, #function - .type Caml_system__frametable, #object + .type caml_allocN, #function + .type caml_call_gc, #function + .type caml_c_call, #function + .type caml_start_program, #function + .type caml_raise_exception, #function + .type caml_system__frametable, #object #endif diff --git a/asmrun/stack.h b/asmrun/stack.h index 62a33e71..9b575cb7 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -19,13 +19,6 @@ #define CAML_STACK_H /* Macros to access the stack frame */ -#ifdef TARGET_alpha -#define Saved_return_address(sp) *((intnat *)((sp) - 8)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1L) -#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - 8)) = (retaddr) | 1L) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1L) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif #ifdef TARGET_sparc #define Saved_return_address(sp) *((intnat *)((sp) + 92)) @@ -41,17 +34,6 @@ #endif #endif -#ifdef TARGET_mips -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -#ifdef TARGET_hppa -#define Stack_grows_upwards -#define Saved_return_address(sp) *((intnat *)(sp)) -#define Callback_link(sp) ((struct caml_context *)((sp) - 24)) -#endif - #ifdef TARGET_power #define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) #define Already_scanned(sp, retaddr) ((retaddr) & 1) @@ -65,34 +47,21 @@ #define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) #endif -#ifdef TARGET_m68k -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - #ifdef TARGET_arm #define Saved_return_address(sp) *((intnat *)((sp) - 4)) #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) #endif -#ifdef TARGET_ia64 -#define Saved_return_address(sp) *((intnat *)((sp) + 8)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1L) -#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) + 8)) = (retaddr) | 1L) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1L) -#define Callback_link(sp) ((struct caml_context *)((sp) + 32)) -#endif - #ifdef TARGET_amd64 #define Saved_return_address(sp) *((intnat *)((sp) - 8)) #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #endif -/* Structure of Caml callback contexts */ +/* Structure of OCaml callback contexts */ struct caml_context { - char * bottom_of_stack; /* beginning of Caml stack chunk */ - uintnat last_retaddr; /* last return address in Caml code */ + char * bottom_of_stack; /* beginning of OCaml stack chunk */ + uintnat last_retaddr; /* last return address in OCaml code */ value * gc_regs; /* pointer to register block */ }; diff --git a/asmrun/startup.c b/asmrun/startup.c index 8bfe7621..a04fa84f 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ @@ -20,10 +20,12 @@ #include "callback.h" #include "backtrace.h" #include "custom.h" +#include "debugger.h" #include "fail.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" +#include "intext.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" @@ -48,6 +50,7 @@ static void init_atoms(void) { extern struct segment caml_data_segments[], caml_code_segments[]; int i; + struct code_fragment * cf; for (i = 0; i < 256; i++) { caml_atom_table[i] = Make_header(0, i, Caml_white); @@ -57,9 +60,11 @@ static void init_atoms(void) caml_fatal_error("Fatal error: not enough memory for the 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, + because pointers equal to caml_data_segments[i].end are static data. */ if (caml_page_table_add(In_static_data, caml_data_segments[i].begin, - caml_data_segments[i].end) != 0) + caml_data_segments[i].end + sizeof(value)) != 0) caml_fatal_error("Fatal error: not enough memory for the initial page table"); } @@ -71,6 +76,13 @@ static void init_atoms(void) if (caml_code_segments[i].end > caml_code_area_end) caml_code_area_end = caml_code_segments[i].end; } + /* Register the code in the table of code fragments */ + cf = caml_stat_alloc(sizeof(struct code_fragment)); + cf->code_start = caml_code_area_start; + cf->code_end = caml_code_area_end; + cf->digest_computed = 0; + caml_ext_table_init(&caml_code_fragments_table, 8); + caml_ext_table_add(&caml_code_fragments_table, cf); } /* Configuration parameters and flags */ diff --git a/boot/.cvsignore b/boot/.cvsignore deleted file mode 100644 index 5eeaef32..00000000 --- a/boot/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -Saved -ocamlrun -ocamlyacc -camlheader -myocamlbuild -myocamlbuild.native -libcamlrun.a diff --git a/boot/.ignore b/boot/.ignore new file mode 100644 index 00000000..a0a2356c --- /dev/null +++ b/boot/.ignore @@ -0,0 +1,6 @@ +Saved +ocamlrun +ocamlyacc +camlheader +myocamlbuild +myocamlbuild.native diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot index 2c7c1f92..0db6ddb8 100755 Binary files a/boot/myocamlbuild.boot and b/boot/myocamlbuild.boot differ diff --git a/boot/ocamlc b/boot/ocamlc index ddc3aa7c..691e46b0 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 2dd0f9e3..6a0417d8 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index bebd06d9..ded272a4 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/.cvsignore b/build/.cvsignore deleted file mode 100644 index 274c6e55..00000000 --- a/build/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -ocamlbuild_mixed_mode diff --git a/build/.ignore b/build/.ignore new file mode 100644 index 00000000..274c6e55 --- /dev/null +++ b/build/.ignore @@ -0,0 +1 @@ +ocamlbuild_mixed_mode diff --git a/build/boot-c-parts.sh b/build/boot-c-parts.sh index 9999392e..fd5a35c7 100755 --- a/build/boot-c-parts.sh +++ b/build/boot-c-parts.sh @@ -1,4 +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. # +# # +######################################################################### + cd `dirname $0`/.. set -ex diff --git a/build/boot.sh b/build/boot.sh index 3de6006a..79d5d20b 100755 --- a/build/boot.sh +++ b/build/boot.sh @@ -1,4 +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. # +# # +######################################################################### + # $Id$ cd `dirname $0`/.. set -ex diff --git a/build/buildbot b/build/buildbot index 82cc26b1..5d3cffba 100755 --- a/build/buildbot +++ b/build/buildbot @@ -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. # +# # +######################################################################### + # If you want to help me by participating to the build/test effort: # http://gallium.inria.fr/~pouillar/ocaml-testing.html # -- Nicolas Pouillard diff --git a/build/camlp4-bootstrap.sh b/build/camlp4-bootstrap.sh index ef9a93c0..612e060e 100755 --- a/build/camlp4-bootstrap.sh +++ b/build/camlp4-bootstrap.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. # +# # +######################################################################### + # README: to bootstrap camlp4 have a look at build/camlp4-bootstrap-recipe.txt set -e diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh index 39b34617..442284d9 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/camlp4-mkCamlp4Ast.sh b/build/camlp4-mkCamlp4Ast.sh index 2a30b9ab..45311065 100755 --- a/build/camlp4-mkCamlp4Ast.sh +++ b/build/camlp4-mkCamlp4Ast.sh @@ -1,4 +1,17 @@ #!/bin/sh + +######################################################################### +# # +# 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. # +# # +######################################################################### + # $Id$ set -e cd `dirname $0`/.. diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index 629684b7..d05932e2 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh index 7c68906a..4f4f5197 100644 --- a/build/camlp4-targets.sh +++ b/build/camlp4-targets.sh @@ -1,4 +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. # +# # +######################################################################### + # $Id$ CAMLP4_COMMON="\ camlp4/Camlp4/Camlp4Ast.partial.ml \ diff --git a/build/distclean.sh b/build/distclean.sh index b3efb3ab..b336f9bb 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/fastworld.sh b/build/fastworld.sh index 82639080..bbe42870 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/install.sh b/build/install.sh index 264d5983..c0ad62f8 100755 --- a/build/install.sh +++ b/build/install.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/mixed-boot.sh b/build/mixed-boot.sh index 122ff412..133f8cff 100755 --- a/build/mixed-boot.sh +++ b/build/mixed-boot.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/mkconfig.sh b/build/mkconfig.sh index d7c2d91e..8cf1773d 100755 --- a/build/mkconfig.sh +++ b/build/mkconfig.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. # +# # +######################################################################### + cd `dirname $0`/.. sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh index 9c7eebd3..600878d8 100755 --- a/build/mkmyocamlbuild_config.sh +++ b/build/mkmyocamlbuild_config.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/mkruntimedef.sh b/build/mkruntimedef.sh index 54f7cc5c..6cfd0749 100755 --- a/build/mkruntimedef.sh +++ b/build/mkruntimedef.sh @@ -1,4 +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. # +# # +######################################################################### + # $Id$ echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh index ad8b71a5..7a029a6a 100755 --- a/build/myocamlbuild.sh +++ b/build/myocamlbuild.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh index 2f226d42..f669e8e6 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index c61f6a1a..f092a789 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index 52bfb8fe..9d666080 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index e3d9fedf..a3890d03 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/partial-install.sh b/build/partial-install.sh index 61997628..81c0e116 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # @@ -131,26 +131,28 @@ installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE -cd camlp4 -CAMLP4DIR=$LIBDIR/camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir -done -installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - camlp4o.cma camlp4of.cma camlp4oof.cma \ - camlp4orf.cma camlp4r.cma camlp4rf.cma \ - Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ - $CAMLP4DIR -installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR -cd .. +if test -d camlp4; then + cd camlp4 + CAMLP4DIR=$LIBDIR/camlp4 + for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do + echo "Installing $dir..." + mkdir -p $CAMLP4DIR/$dir + installdir \ + $dir/*.cm* \ + $dir/*.$O \ + $CAMLP4DIR/$dir + done + installdir \ + camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ + camlp4fulllib.cma camlp4fulllib.cmxa \ + camlp4o.cma camlp4of.cma camlp4oof.cma \ + camlp4orf.cma camlp4r.cma camlp4rf.cma \ + Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ + Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ + $CAMLP4DIR + installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR + cd .. +fi echo "Installing ocamlbuild..." cd ocamlbuild diff --git a/build/targets.sh b/build/targets.sh index 8d698423..d4e5a6a9 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/build/tolower.sed b/build/tolower.sed index ccd55fca..ce0eb165 100644 --- a/build/tolower.sed +++ b/build/tolower.sed @@ -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. # +# # +######################################################################### + # tolower.sed expands one ...<:lower>... to ...foo... per line h s/.*<:lower<\(.*\)>>.*/\1/ diff --git a/build/world.all.sh b/build/world.all.sh index d8a18abb..bf456fc2 100755 --- a/build/world.all.sh +++ b/build/world.all.sh @@ -1,4 +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. # +# # +######################################################################### + # $Id$ set -e cd `dirname $0`/.. diff --git a/build/world.byte.sh b/build/world.byte.sh index d3e96dc4..a30cda2f 100755 --- a/build/world.byte.sh +++ b/build/world.byte.sh @@ -1,4 +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. # +# # +######################################################################### + # $Id$ set -e cd `dirname $0`/.. diff --git a/build/world.native.sh b/build/world.native.sh index ac4a1832..19526805 100755 --- a/build/world.native.sh +++ b/build/world.native.sh @@ -1,4 +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. # +# # +######################################################################### + # $Id$ set -e cd `dirname $0`/.. diff --git a/build/world.sh b/build/world.sh index 534bce54..3b08dc78 100755 --- a/build/world.sh +++ b/build/world.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/bytecomp/.cvsignore b/bytecomp/.cvsignore deleted file mode 100644 index d2f18a85..00000000 --- a/bytecomp/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -runtimedef.ml -opcodes.ml diff --git a/bytecomp/.ignore b/bytecomp/.ignore new file mode 100644 index 00000000..d2f18a85 --- /dev/null +++ b/bytecomp/.ignore @@ -0,0 +1,2 @@ +runtimedef.ml +opcodes.ml diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index b6c8f6fa..105be62d 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -524,6 +524,10 @@ let rec comp_expr env exp sz cont = comp_expr env arg sz cont | Lprim(Pignore, [arg]) -> comp_expr env arg sz (add_const_unit cont) + | Lprim(Pdirapply loc, [func;arg]) + | Lprim(Prevapply loc, [arg;func]) -> + let exp = Lapply(func, [arg], loc) in + comp_expr env exp sz cont | Lprim(Pnot, [arg]) -> let newcont = match cont with diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index 04265fde..e0cd5f61 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index ba08fc01..21427c84 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -55,7 +55,7 @@ let add_ccobjs l = lib_dllibs := !lib_dllibs @ l.lib_dllibs end -let copy_object_file oc name = +let copy_object_file ppf oc name = let file_name = try find_in_path !load_path name @@ -63,13 +63,12 @@ let copy_object_file oc name = raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = String.create (String.length cmo_magic_number) in - really_input ic buffer 0 (String.length cmo_magic_number); + let buffer = input_bytes ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; let compunit = (input_value ic : compilation_unit) in - Bytelink.check_consistency file_name compunit; + Bytelink.check_consistency ppf file_name compunit; copy_compunit ic oc compunit; close_in ic; [compunit] @@ -78,7 +77,7 @@ let copy_object_file oc name = let toc_pos = input_binary_int ic in seek_in ic toc_pos; let toc = (input_value ic : library) in - List.iter (Bytelink.check_consistency file_name) toc.lib_units; + List.iter (Bytelink.check_consistency ppf file_name) toc.lib_units; add_ccobjs toc; List.iter (copy_compunit ic oc) toc.lib_units; close_in ic; @@ -89,13 +88,13 @@ let copy_object_file oc name = End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name)) | x -> close_in ic; raise x -let create_archive file_list lib_name = +let create_archive ppf file_list lib_name = let outchan = open_out_bin lib_name in try 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 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; @@ -118,4 +117,5 @@ let report_error ppf = function | File_not_found name -> fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> - fprintf ppf "The file %s is not a bytecode object file" name + fprintf ppf "The file %a is not a bytecode object file" + Location.print_filename name diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli index a4f9cc2f..24201115 100644 --- a/bytecomp/bytelibrarian.mli +++ b/bytecomp/bytelibrarian.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -21,7 +21,7 @@ content table = list of compilation units *) -val create_archive: string list -> string -> unit +val create_archive: Format.formatter -> string list -> string -> unit type error = File_not_found of string diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 47928008..4f93f0c2 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -29,6 +29,7 @@ type error = | File_exists of string | Cannot_open_dll of string + exception Error of error type link_action = @@ -115,8 +116,7 @@ let scan_file obj_name tolink = raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = String.create (String.length cmo_magic_number) in - really_input ic buffer 0 (String.length cmo_magic_number); + let buffer = input_bytes ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -161,9 +161,10 @@ let scan_file obj_name tolink = (* Consistency check between interfaces *) let crc_interfaces = Consistbl.create () +let implementations_defined = ref ([] : (string * string) list) -let check_consistency file_name cu = - try +let check_consistency ppf file_name cu = + begin try List.iter (fun (name, crc) -> if name = cu.cu_name @@ -172,6 +173,15 @@ let check_consistency file_name cu = cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) + end; + 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)) + with Not_found -> () + end; + implementations_defined := + (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = Consistbl.extract crc_interfaces @@ -182,16 +192,14 @@ let debug_info = ref ([] : (int * string) list) (* Link in a compilation unit *) -let link_compunit output_fun currpos_fun inchan file_name compunit = - check_consistency file_name compunit; +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 = String.create compunit.cu_codesize in - really_input inchan code_block 0 compunit.cu_codesize; + let code_block = input_bytes inchan compunit.cu_codesize in Symtable.patch_object code_block compunit.cu_reloc; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in inchan compunit.cu_debug; - let buffer = String.create compunit.cu_debugsize in - really_input inchan buffer 0 compunit.cu_debugsize; + let buffer = input_bytes inchan compunit.cu_debugsize in debug_info := (currpos_fun(), buffer) :: !debug_info end; output_fun code_block; @@ -200,10 +208,10 @@ let link_compunit output_fun currpos_fun inchan file_name compunit = (* Link in a .cmo file *) -let link_object output_fun currpos_fun file_name compunit = +let link_object ppf output_fun currpos_fun file_name compunit = let inchan = open_in_bin file_name in try - link_compunit output_fun currpos_fun inchan file_name compunit; + link_compunit ppf output_fun currpos_fun inchan file_name compunit; close_in inchan with Symtable.Error msg -> @@ -213,14 +221,14 @@ let link_object output_fun currpos_fun file_name compunit = (* Link in a .cma file *) -let link_archive output_fun currpos_fun file_name units_required = +let link_archive ppf output_fun currpos_fun file_name units_required = let inchan = open_in_bin file_name in try List.iter (fun cu -> let name = file_name ^ "(" ^ cu.cu_name ^ ")" in try - link_compunit output_fun currpos_fun inchan name cu + link_compunit ppf output_fun currpos_fun inchan name cu with Symtable.Error msg -> raise(Error(Symbol_error(name, msg)))) units_required; @@ -229,11 +237,11 @@ let link_archive output_fun currpos_fun file_name units_required = (* Link in a .cmo or .cma file *) -let link_file output_fun currpos_fun = function +let link_file ppf output_fun currpos_fun = function Link_object(file_name, unit) -> - link_object output_fun currpos_fun file_name unit + link_object ppf output_fun currpos_fun file_name unit | Link_archive(file_name, units) -> - link_archive output_fun currpos_fun file_name units + link_archive ppf output_fun currpos_fun file_name units (* Output the debugging information *) (* Format is: @@ -265,7 +273,7 @@ let make_absolute file = (* Create a bytecode executable file *) -let link_bytecode tolink exec_name standalone = +let link_bytecode ppf tolink exec_name standalone = Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *) let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] @@ -276,7 +284,7 @@ let link_bytecode tolink exec_name standalone = try let header = if String.length !Clflags.use_runtime > 0 - then "camlheader_ur" else "camlheader" in + then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant in let inchan = open_in_bin (find_in_path !load_path header) in copy_file inchan outchan; close_in inchan @@ -303,7 +311,7 @@ let link_bytecode tolink exec_name standalone = end; let output_fun = output_string outchan and currpos_fun () = pos_out outchan - start_code in - List.iter (link_file output_fun currpos_fun) tolink; + List.iter (link_file ppf output_fun currpos_fun) tolink; if standalone then Dll.close_all_dlls(); (* The final STOP instruction *) output_byte outchan Opcodes.opSTOP; @@ -402,7 +410,7 @@ let output_cds_file outfile = (* Output a bytecode executable as a C file *) -let link_bytecode_as_c tolink outfile = +let link_bytecode_as_c ppf tolink outfile = let outchan = open_out outfile in begin try (* The bytecode *) @@ -424,7 +432,7 @@ let link_bytecode_as_c tolink outfile = output_code_string outchan code; currpos := !currpos + String.length code and currpos_fun () = !currpos in - List.iter (link_file output_fun currpos_fun) tolink; + List.iter (link_file ppf output_fun currpos_fun) tolink; (* The final STOP instruction *) Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP; (* The table of global data *) @@ -458,6 +466,7 @@ let link_bytecode_as_c tolink outfile = close_out outchan with x -> close_out outchan; + remove_file outfile; raise x end; if !Clflags.debug then @@ -466,8 +475,9 @@ let link_bytecode_as_c tolink outfile = (* Build a custom runtime *) let build_custom_runtime prim_name exec_name = + let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in Ccomp.call_linker Ccomp.Exe exec_name - ([prim_name] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"]) + ([prim_name] @ List.rev !Clflags.ccobjs @ [runtime_lib]) (Clflags.std_include_flag "-I" ^ " " ^ Config.bytecomp_c_libraries) let append_bytecode_and_cleanup bytecode_name exec_name prim_name = @@ -490,7 +500,7 @@ let fix_exec_name name = (* Main entry point (build a custom runtime if needed) *) -let link objfiles output_name = +let link ppf objfiles output_name = let objfiles = if !Clflags.nopervasives then objfiles else if !Clflags.output_c_object then "stdlib.cma" :: objfiles @@ -500,19 +510,23 @@ let link objfiles output_name = Clflags.ccopts := !lib_ccopts @ !Clflags.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 tolink output_name true + link_bytecode ppf tolink output_name true else if not !Clflags.output_c_object then begin let bytecode_name = Filename.temp_file "camlcode" "" in let prim_name = Filename.temp_file "camlprim" ".c" in try - link_bytecode tolink bytecode_name false; + link_bytecode ppf tolink bytecode_name false; let poc = open_out prim_name in output_string poc "\ #ifdef __cplusplus\n\ extern \"C\" {\n\ #endif\n\ #ifdef _WIN64\n\ + #ifdef __MINGW32__\n\ + typedef long long value;\n\ + #else\n\ typedef __int64 value;\n\ + #endif\n\ #else\n\ typedef long value;\n\ #endif\n"; @@ -539,15 +553,16 @@ let link objfiles output_name = if Sys.file_exists c_file then raise(Error(File_exists c_file)); let temps = ref [] in try - link_bytecode_as_c tolink c_file; + link_bytecode_as_c ppf tolink c_file; if not (Filename.check_suffix output_name ".c") then begin temps := c_file :: !temps; if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime); if not (Filename.check_suffix output_name Config.ext_obj) then begin temps := obj_file :: !temps; if not ( + let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in Ccomp.call_linker Ccomp.MainDll output_name - ([obj_file] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"]) + ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) Config.bytecomp_c_libraries ) then raise (Error Custom_runtime); end @@ -564,20 +579,25 @@ open Format let report_error ppf = function | File_not_found name -> - fprintf ppf "Cannot find file %s" name + fprintf ppf "Cannot find file %a" Location.print_filename name | Not_an_object_file name -> - fprintf ppf "The file %s is not a bytecode object file" name + fprintf ppf "The file %a is not a bytecode object file" + Location.print_filename name | Symbol_error(name, err) -> - fprintf ppf "Error while linking %s:@ %a" name + fprintf ppf "Error while linking %a:@ %a" Location.print_filename name Symtable.report_error err | Inconsistent_import(intf, file1, file2) -> fprintf ppf - "@[Files %s@ and %s@ \ + "@[Files %a@ and %a@ \ make inconsistent assumptions over interface %s@]" - file1 file2 intf + Location.print_filename file1 + Location.print_filename file2 + intf | Custom_runtime -> fprintf ppf "Error while building custom runtime system" | File_exists file -> - fprintf ppf "Cannot overwrite existing file %s" file + fprintf ppf "Cannot overwrite existing file %a" + Location.print_filename file | Cannot_open_dll file -> - fprintf ppf "Error on dynamically loaded library: %s" file + fprintf ppf "Error on dynamically loaded library: %a" + Location.print_filename file diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 2e8f0cb3..1366a168 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -14,9 +14,9 @@ (* Link .cmo files and produce a bytecode executable. *) -val link: string list -> string -> unit +val link : Format.formatter -> string list -> string -> unit -val check_consistency: 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 diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index e2b6ff54..089c5f6d 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -100,8 +100,7 @@ let read_member_info file = if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in try - let buffer = String.create (String.length Config.cmo_magic_number) in - really_input ic buffer 0 (String.length Config.cmo_magic_number); + let buffer = input_bytes ic (String.length Config.cmo_magic_number) in if buffer <> Config.cmo_magic_number then raise(Error(Not_an_object_file file)); let compunit_pos = input_binary_int ic in @@ -124,10 +123,10 @@ let read_member_info file = Accumulate relocs, debug info, etc. Return size of bytecode. *) -let rename_append_bytecode 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 objfile compunit; + Bytelink.check_consistency ppf objfile compunit; List.iter (rename_relocation packagename objfile mapping defined ofs) compunit.cu_reloc; @@ -148,20 +147,20 @@ let rename_append_bytecode packagename oc mapping defined ofs prefix subst objfi (* Same, for a list of .cmo and .cmi files. Return total size of bytecode. *) -let rec rename_append_bytecode_list 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 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 packagename oc mapping defined ofs prefix subst + 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 packagename + 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 @@ -186,7 +185,7 @@ let build_global_target oc target_name members mapping pos coercion = (* Build the .cmo file obtained by packaging the given .cmo files. *) -let package_object_files files targetfile targetname coercion = +let package_object_files ppf files targetfile targetname coercion = let members = map_left_right read_member_info files in let unit_names = @@ -203,7 +202,7 @@ let package_object_files 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 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 @@ -233,19 +232,20 @@ let package_object_files files targetfile targetname coercion = (* The entry point *) -let package_files files targetfile = - let files = +let package_files ppf files targetfile = + let files = List.map - (fun f -> + (fun f -> try find_in_path !Config.load_path f with Not_found -> raise(Error(File_not_found f))) - files in - let prefix = chop_extensions targetfile in - let targetcmi = prefix ^ ".cmi" in - let targetname = String.capitalize(Filename.basename prefix) in - try - let coercion = Typemod.package_units files targetcmi targetname in - package_object_files files targetfile targetname coercion + files in + let prefix = chop_extensions targetfile in + let targetcmi = prefix ^ ".cmi" in + let targetname = String.capitalize(Filename.basename prefix) in + try + let coercion = Typemod.package_units files targetcmi targetname in + let ret = package_object_files ppf files targetfile targetname coercion in + ret with x -> remove_file targetfile; raise x @@ -255,13 +255,17 @@ open Format let report_error ppf = function Forward_reference(file, ident) -> - fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file + fprintf ppf "Forward reference to %s in file %a" (Ident.name ident) + Location.print_filename file | Multiple_definition(file, ident) -> - fprintf ppf "File %s redefines %s" file (Ident.name ident) + fprintf ppf "File %a redefines %s" + Location.print_filename file + (Ident.name ident) | Not_an_object_file file -> - fprintf ppf "%s is not a bytecode 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: %s@ contains the code for@ %s" - file id + fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" + Location.print_filename file id | File_not_found file -> fprintf ppf "File %s not found" file diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index 836eb9c6..696b12aa 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -15,7 +15,7 @@ (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: string list -> string -> unit +val package_files: Format.formatter -> string list -> string -> unit type error = Forward_reference of string * Ident.t diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 16eaf237..518e2254 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -48,14 +48,12 @@ let read_toc ic = let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = String.create(String.length Config.exec_magic_number) in - really_input ic header 0 (String.length Config.exec_magic_number); + let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for i = 1 to num_sections do - let name = String.create 4 in - really_input ic name 0 4; + let name = Misc.input_bytes ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -81,10 +79,7 @@ let seek_section ic name = (* Return the contents of a section, as a string *) let read_section_string ic name = - let len = seek_section ic name in - let res = String.create len in - really_input ic res 0 len; - res + Misc.input_bytes ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli index 5292cc1b..c9264ad8 100644 --- a/bytecomp/bytesections.mli +++ b/bytecomp/bytesections.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index c87e6df4..b0cd05d6 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index bcf66b42..6109028f 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index fea455f7..a4841d3d 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 2cec99dc..f9a33db7 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index fa20de18..55f3dff1 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 4f4fa14f..7757c7d4 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -107,5 +107,5 @@ let immed_min = -0x40000000 and immed_max = 0x3FFFFFFF (* Actually the abstract machine accomodates -0x80000000 to 0x7FFFFFFF, - but these numbers overflow the Caml type int if the compiler runs on + but these numbers overflow the OCaml type int if the compiler runs on a 32-bit processor. *) diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 6b9367f9..0fdccd29 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 06523ebc..2e2875d8 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -19,6 +19,8 @@ open Asttypes type primitive = Pidentity | Pignore + | Prevapply of Location.t + | Pdirapply of Location.t (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index e671b891..c228d36d 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -19,6 +19,8 @@ open Asttypes type primitive = Pidentity | Pignore + | Prevapply of Location.t + | Pdirapply of Location.t (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 21006cc6..f0b22374 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -2037,7 +2037,7 @@ let combine_constructor arg ex_pat cstr partial ctx def List.fold_right (fun (ex, act) rem -> match ex with - | Cstr_exception path -> + | Cstr_exception (path, _) -> Lifthenelse(Lprim(Pintcomp Ceq, [Lprim(Pfield 0, [arg]); transl_path path]), act, rem) @@ -2542,13 +2542,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial = let partial_function loc () = (* [Location.get_pos_info] is too expensive *) - let fname = match loc.Location.loc_start.Lexing.pos_fname with - | "" -> !Location.input_name - | x -> x - in - let pos = loc.Location.loc_start in - let line = pos.Lexing.pos_lnum in - let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), [transl_path Predef.path_match_failure; Lconst(Const_block(0, diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index ebfed841..d8ea7910 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index a4beaf42..732bcc8a 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index 774c5f13..93be656a 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 2f0508b2..f2aa87dc 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/printinstr.mli b/bytecomp/printinstr.mli index e88e76ff..57cea578 100644 --- a/bytecomp/printinstr.mli +++ b/bytecomp/printinstr.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 9bfa099e..cb99003b 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -92,6 +92,8 @@ let record_rep ppf r = let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" + | Prevapply _ -> fprintf ppf "revapply" + | Pdirapply _ -> fprintf ppf "dirapply" | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -297,7 +299,10 @@ let rec lam ppf = function | Lev_before -> "before" | Lev_after _ -> "after" | Lev_function -> "funct-body" in - fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind + fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind + ev.lev_loc.Location.loc_start.Lexing.pos_fname + ev.lev_loc.Location.loc_start.Lexing.pos_lnum + (if ev.lev_loc.Location.loc_ghost then "" else "") ev.lev_loc.Location.loc_start.Lexing.pos_cnum ev.lev_loc.Location.loc_end.Lexing.pos_cnum lam expr diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli index 352d6d02..0cbd59ed 100644 --- a/bytecomp/printlambda.mli +++ b/bytecomp/printlambda.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -18,3 +18,4 @@ open Format val structured_constant: formatter -> structured_constant -> unit val lambda: formatter -> lambda -> unit +val primitive: formatter -> primitive -> unit diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli index 27309f60..48920009 100644 --- a/bytecomp/runtimedef.mli +++ b/bytecomp/runtimedef.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index cd942ca2..1883f715 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -190,7 +190,23 @@ let simplify_exits lam = | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll) -> Lprim(p, List.map simplif ll) + | Lprim(p, ll) -> begin + let ll = List.map simplif ll in + match p, ll with + (* Simplify %revapply, for n-ary functions with n > 1 *) + | Prevapply loc, [x; Lapply(f, args, _)] + | Prevapply loc, [x; Levent (Lapply(f, args, _),_)] -> + Lapply(f, args@[x], loc) + | Prevapply loc, [x; f] -> Lapply(f, [x], loc) + + (* Simplify %apply, for n-ary functions with n > 1 *) + | Pdirapply loc, [Lapply(f, args, _); x] + | Pdirapply loc, [Levent (Lapply(f, args, _),_); x] -> + Lapply(f, args@[x], loc) + | Pdirapply loc, [f; x] -> Lapply(f, [x], loc) + + | _ -> Lprim(p, ll) + end | Lswitch(l, sw) -> let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts @@ -256,69 +272,113 @@ let simplify_exits lam = in simplif lam +(* Compile-time beta-reduction of functions immediately applied: + Lapply(Lfunction(Curried, params, body), args, loc) -> + let paramN = argN in ... let param1 = arg1 in body + Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> + let paramN = argN in ... let param1 = arg1 in body + Assumes |args| = |params|. +*) + +let beta_reduce params body args = + List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l)) + body params args + (* Simplification of lets *) let simplify_lets lam = - (* First pass: count the occurrences of all identifiers *) - let occ = Hashtbl.create 83 in + (* Disable optimisations for bytecode compilation with -g flag *) + let optimize = !Clflags.native_code || not !Clflags.debug in + + (* First pass: count the occurrences of all let-bound identifiers *) + + let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in + (* The global table [occ] associates to each let-bound identifier + the number of its uses (as a reference): + - 0 if never used + - 1 if used exactly once in and not under a lambda or within a loop + - > 1 if used several times or under a lambda or within a loop. + The local table [bv] associates to each locally-let-bound variable + its reference count, as above. [bv] is enriched at let bindings + but emptied when crossing lambdas and loops. *) + + (* Current use count of a variable. *) let count_var v = try !(Hashtbl.find occ v) with Not_found -> 0 - and incr_var v = + + (* Entering a [let]. Returns updated [bv]. *) + and bind_var bv v = + let r = ref 0 in + Hashtbl.add occ v r; + Tbl.add v r bv + + (* Record a use of a variable *) + and use_var bv v n = + try + let r = Tbl.find v bv in r := !r + n + with Not_found -> + (* v is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) try - incr(Hashtbl.find occ v) + let r = Hashtbl.find occ v in r := !r + 2 with Not_found -> - Hashtbl.add occ v (ref 1) in + (* Not a let-bound variable, ignore *) + () in - let rec count = function - | Lvar v -> incr_var v + let rec count bv = function | Lconst cst -> () - | Lapply(l1, ll, _) -> count l1; List.iter count ll - | Lfunction(kind, params, l) -> count l - | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> + | Lvar v -> + use_var bv v 1 + | Lapply(Lfunction(Curried, params, body), args, _) + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply(l1, ll, _) -> + count bv l1; List.iter (count bv) ll + | Lfunction(kind, params, l) -> + count Tbl.empty l + | Llet(str, v, Lvar w, l2) when optimize -> (* v will be replaced by w in l2, so each occurrence of v in l2 increases w's refcount *) - count l2; - let vc = count_var v in - begin try - let r = Hashtbl.find occ w in r := !r + vc - with Not_found -> - Hashtbl.add occ w (ref vc) - end + count (bind_var bv v) l2; + use_var bv w (count_var v) | Llet(str, v, l1, l2) -> - count l2; + count (bind_var bv v) l2; (* If v is unused, l1 will be removed, so don't count its variables *) - if str = Strict || count_var v > 0 then count l1 + if str = Strict || count_var v > 0 then count bv l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count l) bindings; - count body - | Lprim(p, ll) -> List.iter count ll + List.iter (fun (v, l) -> count bv l) bindings; + count bv body + | Lprim(p, ll) -> List.iter (count bv) ll | Lswitch(l, sw) -> - count_default sw ; - count l; - List.iter (fun (_, l) -> count l) sw.sw_consts; - List.iter (fun (_, l) -> count l) sw.sw_blocks - | Lstaticraise (i,ls) -> List.iter count ls - | Lstaticcatch(l1, (i,_), l2) -> - count l1; count l2 - | Ltrywith(l1, v, l2) -> count l1; count l2 - | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 - | Lsequence(l1, l2) -> count l1; count l2 - | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 + count_default bv sw ; + count bv l; + List.iter (fun (_, l) -> count bv l) sw.sw_consts; + List.iter (fun (_, l) -> count bv l) sw.sw_blocks + | Lstaticraise (i,ls) -> List.iter (count bv) ls + | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 + | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 + | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 + | Lsequence(l1, l2) -> count bv l1; count bv l2 + | Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2 + | Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 | Lassign(v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refcount *) - count l - | Lsend(_, m, o, ll, _) -> List.iter count (m::o::ll) - | Levent(l, _) -> count l + count bv l + | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) + | Levent(l, _) -> count bv l | Lifused(v, l) -> - if count_var v > 0 then count l + if count_var v > 0 then count bv l - and count_default sw = match sw.sw_failaction with + and count_default bv sw = match sw.sw_failaction with | None -> () | Some al -> let nconsts = List.length sw.sw_consts @@ -326,18 +386,27 @@ let simplify_lets lam = if nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks then begin (* default action will occur twice in native code *) - count al ; count al + count bv al ; count bv al end else begin (* default action will occur once *) assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count al + count bv al end in - count lam; + count Tbl.empty lam; + (* Second pass: remove Lalias bindings of unused variables, and substitute the bindings of variables used exactly once. *) let subst = Hashtbl.create 83 in +(* This (small) optimisation is always legal, it may uncover some + tail call later on. *) + + let mklet (kind,v,e1,e2) = match e2 with + | Lvar w when optimize && Ident.same v w -> e1 + | _ -> Llet (kind,v,e1,e2) in + + let rec simplif = function Lvar v as l -> begin try @@ -346,33 +415,38 @@ let simplify_lets lam = l end | Lconst cst as l -> l + | Lapply(Lfunction(Curried, params, body), args, _) + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) + | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) - | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> + | Llet(str, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody) - when not !Clflags.debug -> + when optimize -> let slinit = simplif linit in let slbody = simplif lbody in begin try - Llet(Variable, v, slinit, eliminate_ref v slbody) + mklet (Variable, v, slinit, eliminate_ref v slbody) with Real_reference -> - Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody) + mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody) end | Llet(Alias, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 - | 1 when not !Clflags.debug -> - Hashtbl.add subst v (simplif l1); simplif l2 + | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 | n -> Llet(Alias, v, simplif l1, simplif l2) end | Llet(StrictOpt, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 - | n -> Llet(Alias, v, simplif l1, simplif l2) + | n -> mklet(Alias, v, simplif l1, simplif l2) end - | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) + | Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) | Lprim(p, ll) -> Lprim(p, List.map simplif ll) diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli index 2d9b352b..816c44b8 100644 --- a/bytecomp/simplif.mli +++ b/bytecomp/simplif.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index 4fa7b62b..ff193ee1 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 33014c0f..69fc800d 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 136144ef..4e5f1475 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -55,6 +55,9 @@ let incr_numtable nt = let global_table = ref(empty_numtable : Ident.t numtable) and literal_table = ref([] : (int * structured_constant) list) +let is_global_defined id = + Tbl.mem id (!global_table).num_tbl + let slot_for_getglobal id = try find_numtable !global_table id diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index cbef01e2..d9a2be35 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -33,6 +33,7 @@ val data_primitive_names: unit -> string val init_toplevel: unit -> (string * Digest.t) list val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t +val is_global_defined: Ident.t -> bool val assign_global_value: Ident.t -> Obj.t -> unit val get_global_position: Ident.t -> int val check_global_initialized: (reloc_info * int) list -> unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index e18a13ba..843ef5a9 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) @@ -142,15 +142,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = (inh_init, obj_init, has_init) | Cf_init _ -> (inh_init, obj_init, true) - | Cf_let (rec_flag, defs, vals) -> - (inh_init, - Translcore.transl_let rec_flag defs - (List.fold_right - (fun (id, expr) rem -> - lsequence (Lifused(id, set_inst_var obj id expr)) - rem) - vals obj_init), - has_init)) + ) str.cl_field (inh_init, obj_init obj, false) in @@ -292,11 +284,6 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = (inh_init, cl_init, Lvar (Meths.find name str.cl_meths) :: met_code @ methods, values) - | Cf_let (rec_flag, defs, vals) -> - let vals = - List.map (function (id, _) -> (Ident.name id, id)) vals - in - (inh_init, cl_init, methods, vals @ values) | Cf_init exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index 4938278f..7a5d6d14 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 3b0b0b0d..77468a58 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -28,6 +28,7 @@ type error = Illegal_letrec_pat | Illegal_letrec_expr | Free_super_var + | Unknown_builtin_primitive of string exception Error of Location.t * error @@ -285,12 +286,13 @@ let prim_obj_dup = { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true; prim_native_name = ""; prim_native_float = false } -let transl_prim prim args = +let transl_prim loc prim args = + let prim_name = prim.prim_name in try let (gencomp, intcomp, floatcomp, stringcomp, nativeintcomp, int32comp, int64comp, simplify_constant_constructor) = - Hashtbl.find comparisons_table prim.prim_name in + Hashtbl.find comparisons_table prim_name in begin match args with [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] when simplify_constant_constructor -> @@ -322,7 +324,11 @@ let transl_prim prim args = end with Not_found -> try - let p = Hashtbl.find primitives_table prim.prim_name in + let p = + match prim_name with + "%revapply" -> Prevapply loc + | "%apply" -> Pdirapply loc + | name -> Hashtbl.find primitives_table name in (* Try strength reduction based on the type of the argument *) begin match (p, args) with (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2) @@ -342,6 +348,8 @@ let transl_prim prim args = | _ -> p end with Not_found -> + if String.length prim_name > 0 && prim_name.[0] = '%' then + raise(Error(loc, Unknown_builtin_primitive prim_name)); Pccall prim @@ -481,7 +489,9 @@ let rec push_defaults loc bindings pat_expr_list partial = Texp_match ({exp with exp_type = pat.pat_type; exp_desc = Texp_ident (Path.Pident param, - {val_type = pat.pat_type; val_kind = Val_reg})}, + {val_type = pat.pat_type; val_kind = Val_reg; + val_loc = Location.none; + })}, pat_expr_list, partial) } in push_defaults loc bindings @@ -530,21 +540,16 @@ let primitive_is_ccall = function (* Assertions *) -let assert_failed loc = - (* [Location.get_pos_info] is too expensive *) - let fname = match loc.Location.loc_start.Lexing.pos_fname with - | "" -> !Location.input_name - | x -> x - in - let pos = loc.Location.loc_start in - let line = pos.Lexing.pos_lnum in - let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in - Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), +let assert_failed exp = + let (fname, line, char) = + Location.get_pos_info exp.exp_loc.Location.loc_start in + Lprim(Praise, [event_after exp + (Lprim(Pmakeblock(0, Immutable), [transl_path Predef.path_assert_failure; Lconst(Const_block(0, [Const_base(Const_string fname); Const_base(Const_int line); - Const_base(Const_int char)]))])]) + Const_base(Const_int char)]))]))]) ;; let rec cut n l = @@ -620,7 +625,7 @@ and transl_exp0 e = wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin - let prim = transl_prim p args in + let prim = transl_prim e.exp_loc p args in match (prim, args) with (Praise, [arg1]) -> wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) @@ -663,7 +668,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception path -> + | Cstr_exception (path, _) -> Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) end | Texp_variant(l, arg) -> @@ -767,8 +772,8 @@ and transl_exp0 e = | Texp_assert (cond) -> if !Clflags.noassert then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc) - | Texp_assertfalse -> assert_failed e.exp_loc + else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + | Texp_assertfalse -> assert_failed e | Texp_lazy e -> (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would @@ -787,12 +792,13 @@ and transl_exp0 e = begin match e.exp_type.desc with (* the following may represent a float/forward/lazy: need a forward_tag *) - | Tvar | Tlink _ | Tsubst _ | Tunivar + | Tvar _ | Tlink _ | Tsubst _ | Tunivar _ | Tpoly(_,_) | Tfield(_,_,_,_) -> Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) (* the following cannot be represented as float/forward/lazy: optimize *) - | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _ + | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil + | Tvariant _ -> transl_exp e (* optimize predefined types (excepted float) *) | Tconstr(_,_,_) -> @@ -934,6 +940,7 @@ and transl_let rec_flag pat_expr_list body = (fun (pat, expr) -> match pat.pat_desc with Tpat_var id -> id + | Tpat_alias ({pat_desc=Tpat_any}, id) -> id | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) pat_expr_list in let transl_case (pat, expr) id = @@ -1048,3 +1055,5 @@ let report_error ppf = function | Free_super_var -> fprintf ppf "Ancestor names can only be used to select inherited methods" + | Unknown_builtin_primitive prim_name -> + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index baac0556..5cb22775 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -37,6 +37,7 @@ type error = Illegal_letrec_pat | Illegal_letrec_expr | Free_super_var + | Unknown_builtin_primitive of string exception Error of Location.t * error diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index bd6107f0..38eab854 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -109,13 +109,7 @@ let mod_prim name = fatal_error ("Primitive " ^ name ^ " not found.") let undefined_location loc = - (* Confer Translcore.assert_failed *) - let fname = match loc.Location.loc_start.Lexing.pos_fname with - | "" -> !Location.input_name - | x -> x in - let pos = loc.Location.loc_start in - let line = pos.Lexing.pos_lnum in - let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lconst(Const_block(0, [Const_base(Const_string fname); Const_base(Const_int line); @@ -267,7 +261,7 @@ let rec transl_module cc rootpath mexp = | Tmod_constraint(arg, mty, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> - Translcore.transl_exp arg + apply_coercion cc (Translcore.transl_exp arg) and transl_structure fields cc rootpath = function [] -> diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 9e47ca5e..5b6d0a00 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index a0df551d..f72e34b0 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 26fa504b..be1e6a90 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index f8e43f0d..e80148f0 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -37,9 +37,9 @@ let maybe_pointer exp = not (Path.same p Predef.path_char) && begin try match Env.find_type p exp.exp_env with - {type_kind = Type_variant []} -> true (* type exn *) + | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun (name, args) -> args <> []) cstrs + List.exists (fun (name, args,_) -> args <> []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -50,7 +50,7 @@ let maybe_pointer exp = let array_element_kind env ty = match scrape env ty with - | Tvar | Tunivar -> + | Tvar _ | Tunivar _ -> Pgenarray | Tconstr(p, args, abbrev) -> if Path.same p Predef.path_int || Path.same p Predef.path_char then @@ -69,7 +69,7 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args) -> args = []) cstrs -> + when List.for_all (fun (name, args,_) -> args = []) cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli index 811c2da3..163ca44d 100644 --- a/bytecomp/typeopt.mli +++ b/bytecomp/typeopt.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/byterun/.cvsignore b/byterun/.cvsignore deleted file mode 100644 index 8873b77f..00000000 --- a/byterun/.cvsignore +++ /dev/null @@ -1,20 +0,0 @@ -jumptbl.h -primitives -prims.c -opnames.h -version.h -ocamlrun -ocamlrund -ld.conf -libcamlrun.x -libcamlrun-gui.x -*.c.x -ocamlrun.xcoff -ocamlrun.dbg -interp.a.lst -*.[sd]obj -*.lib -.gdb_history -*.so -*.a -.depend.nt diff --git a/byterun/.depend b/byterun/.depend index b92cc6de..68adc27b 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -6,7 +6,7 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ @@ -20,15 +20,15 @@ compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \ custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h -debugger.o: debugger.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ +debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ @@ -38,7 +38,8 @@ finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -54,18 +55,18 @@ globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + minor_gc.h hash.h int64_native.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -142,7 +143,7 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ @@ -156,15 +157,15 @@ compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \ custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h -debugger.d.o: debugger.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ +debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ @@ -174,7 +175,8 @@ finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -190,20 +192,20 @@ globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + minor_gc.h hash.h int64_native.h instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -280,7 +282,7 @@ array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ @@ -294,15 +296,15 @@ compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h -debugger.pic.o: debugger.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ +debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ @@ -312,7 +314,8 @@ finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -328,18 +331,18 @@ globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + minor_gc.h hash.h int64_native.h instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h diff --git a/byterun/.ignore b/byterun/.ignore new file mode 100644 index 00000000..59302e05 --- /dev/null +++ b/byterun/.ignore @@ -0,0 +1,14 @@ +jumptbl.h +primitives +prims.c +opnames.h +version.h +ocamlrun +ocamlrund +ld.conf +interp.a.lst +*.[sd]obj +*.lib +.gdb_history +*.d.c +*.pic.c diff --git a/byterun/Makefile b/byterun/Makefile index 8ee62aee..316f69e5 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -53,20 +53,20 @@ install:: clean:: rm -f libcamlrun_shared.so - .SUFFIXES: .d.o .pic.o .c.d.o: - @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi - $(CC) -c $(DFLAGS) $< - mv $*.o $*.d.o - @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi + ln -s -f $*.c $*.d.c + $(CC) -c $(DFLAGS) $*.d.c + rm $*.d.c .c.pic.o: - @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi - $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< - mv $*.o $*.pic.o - @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi + ln -s -f $*.c $*.pic.c + $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c + rm $*.pic.c + +clean:: + rm -f *.pic.c *.d.c depend : prims.c opnames.h jumptbl.h version.h -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend diff --git a/byterun/Makefile.common b/byterun/Makefile.common index cc75cced..7f21fd8d 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -33,13 +33,19 @@ PRIMS=\ dynlink.c backtrace.c PUBLIC_INCLUDES=\ - alloc.h callback.h config.h custom.h fail.h intext.h \ + alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h -all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) +all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) .PHONY: all +all-noruntimed: +.PHONY: all-noruntimed + +all-runtimed: ocamlrund$(EXE) libcamlrund.$(A) +.PHONY: all-runtimed + ld.conf: ../config/Makefile echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf @@ -55,6 +61,15 @@ install:: cp ld.conf $(LIBDIR)/ld.conf .PHONY: install +install:: install-$(RUNTIMED) + +install-noruntimed: +.PHONY: install-noruntimed + +install-runtimed: + cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) + cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) +.PHONY: install-runtimed primitives : $(PRIMS) sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index a633787d..b93fa58a 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # diff --git a/byterun/alloc.c b/byterun/alloc.c index cc19698a..034562e8 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/alloc.h b/byterun/alloc.h index 66cab702..75dd5ec8 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ @@ -23,6 +23,10 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern value caml_alloc (mlsize_t, tag_t); CAMLextern value caml_alloc_small (mlsize_t, tag_t); CAMLextern value caml_alloc_tuple (mlsize_t); @@ -44,4 +48,8 @@ CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ CAMLextern int caml_convert_flag_list (value, int *); +#ifdef __cplusplus +} +#endif + #endif /* CAML_ALLOC_H */ diff --git a/byterun/array.c b/byterun/array.c index fc606595..637fe9c8 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -15,12 +15,26 @@ /* Operations on arrays */ +#include #include "alloc.h" #include "fail.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" +CAMLexport mlsize_t caml_array_length(value array) +{ + if (Tag_val(array) == Double_array_tag) + return Wosize_val(array) / Double_wosize; + else + return Wosize_val(array); +} + +CAMLexport int caml_is_double_array(value array) +{ + return (Tag_val(array) == Double_array_tag); +} + CAMLprim value caml_array_get_addr(value array, value index) { intnat idx = Long_val(index); @@ -191,3 +205,181 @@ CAMLprim value caml_make_array(value init) } } } + +/* Blitting */ + +CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2, + value n) +{ + value * src, * dst; + intnat count; + + if (Tag_val(a2) == Double_array_tag) { + /* Arrays of floats. The values being copied are floats, not + pointer, so we can do a direct copy. memmove takes care of + potential overlap between the copied areas. */ + memmove((double *)a2 + Long_val(ofs2), + (double *)a1 + Long_val(ofs1), + Long_val(n) * sizeof(double)); + return Val_unit; + } + if (Is_young(a2)) { + /* Arrays of values, destination is in young generation. + Here too we can do a direct copy since this cannot create + old-to-young pointers, nor mess up with the incremental major GC. + Again, memmove takes care of overlap. */ + memmove(&Field(a2, Long_val(ofs2)), + &Field(a1, Long_val(ofs1)), + Long_val(n) * sizeof(value)); + return Val_unit; + } + /* Array of values, destination is in old generation. + We must use caml_modify. */ + count = Long_val(n); + if (a1 == a2 && Long_val(ofs1) < Long_val(ofs2)) { + /* Copy in descending order */ + for (dst = &Field(a2, Long_val(ofs2) + count - 1), + src = &Field(a1, Long_val(ofs1) + count - 1); + count > 0; + count--, src--, dst--) { + caml_modify(dst, *src); + } + } else { + /* Copy in ascending order */ + for (dst = &Field(a2, Long_val(ofs2)), src = &Field(a1, Long_val(ofs1)); + count > 0; + count--, src++, dst++) { + caml_modify(dst, *src); + } + } + /* Many caml_modify in a row can create a lot of old-to-young refs. + Give the minor GC a chance to run if it needs to. */ + caml_check_urgent_gc(Val_unit); + return Val_unit; +} + +/* A generic function for extraction and concatenation of sub-arrays */ + +static value caml_array_gather(intnat num_arrays, + value arrays[/*num_arrays*/], + intnat offsets[/*num_arrays*/], + intnat lengths[/*num_arrays*/]) +{ + CAMLparamN(arrays, num_arrays); + value res; /* no need to register it as a root */ + int isfloat; + mlsize_t i, size, wsize, count, pos; + value * src; + + /* Determine total size and whether result array is an array of floats */ + size = 0; + isfloat = 0; + for (i = 0; i < num_arrays; i++) { + size += lengths[i]; + if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1; + } + if (size == 0) { + /* If total size = 0, just return empty array */ + res = Atom(0); + } + else if (isfloat) { + /* This is an array of floats. We can use memcpy directly. */ + wsize = size * Double_wosize; + if (wsize > Max_wosize) caml_invalid_argument("Array.concat"); + res = caml_alloc(wsize, Double_array_tag); + for (i = 0, pos = 0; i < num_arrays; i++) { + memcpy((double *)res + pos, + (double *)arrays[i] + offsets[i], + lengths[i] * sizeof(double)); + pos += lengths[i]; + } + Assert(pos == size); + } + else if (size > Max_wosize) { + /* Array of values, too big. */ + caml_invalid_argument("Array.concat"); + } + else if (size < Max_young_wosize) { + /* Array of values, small enough to fit in young generation. + We can use memcpy directly. */ + res = caml_alloc_small(size, 0); + for (i = 0, pos = 0; i < num_arrays; i++) { + memcpy(&Field(res, pos), + &Field(arrays[i], offsets[i]), + lengths[i] * sizeof(value)); + pos += lengths[i]; + } + Assert(pos == size); + } else { + /* Array of values, must be allocated in old generation and filled + using caml_initialize. */ + res = caml_alloc_shr(size, 0); + pos = 0; + for (i = 0, pos = 0; i < num_arrays; i++) { + for (src = &Field(arrays[i], offsets[i]), count = lengths[i]; + count > 0; + 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); + } + CAMLreturn (res); +} + +CAMLprim value caml_array_sub(value a, value ofs, value len) +{ + value arrays[1] = { a }; + intnat offsets[1] = { Long_val(ofs) }; + intnat lengths[1] = { Long_val(len) }; + return caml_array_gather(1, arrays, offsets, lengths); +} + +CAMLprim value caml_array_append(value a1, value a2) +{ + value arrays[2] = { a1, a2 }; + intnat offsets[2] = { 0, 0 }; + intnat lengths[2] = { caml_array_length(a1), caml_array_length(a2) }; + return caml_array_gather(2, arrays, offsets, lengths); +} + +CAMLprim value caml_array_concat(value al) +{ +#define STATIC_SIZE 16 + value static_arrays[STATIC_SIZE], * arrays; + intnat static_offsets[STATIC_SIZE], * offsets; + intnat static_lengths[STATIC_SIZE], * lengths; + intnat n, i; + value l, res; + + /* Length of list = number of arrays */ + for (n = 0, l = al; l != Val_int(0); l = Field(l, 1)) n++; + /* Allocate extra storage if too many arrays */ + if (n <= STATIC_SIZE) { + arrays = static_arrays; + offsets = static_offsets; + lengths = static_lengths; + } else { + arrays = caml_stat_alloc(n * sizeof(value)); + offsets = caml_stat_alloc(n * sizeof(intnat)); + lengths = caml_stat_alloc(n * sizeof(value)); + } + /* Build the parameters to caml_array_gather */ + for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) { + arrays[i] = Field(l, 0); + offsets[i] = 0; + lengths[i] = caml_array_length(Field(l, 0)); + } + /* Do the concatenation */ + res = caml_array_gather(n, arrays, offsets, lengths); + /* Free the extra storage if needed */ + if (n > STATIC_SIZE) { + caml_stat_free(arrays); + caml_stat_free(offsets); + caml_stat_free(lengths); + } + return res; +} diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 2b29c31d..b5efdc3d 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -118,7 +118,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } /* Read the debugging info contained in the current bytecode executable. - Return a Caml array of Caml lists of debug_event records in "events", + Return an OCaml array of OCaml lists of debug_event records in "events", or Val_false on failure. */ #ifndef O_BINARY @@ -274,7 +274,7 @@ CAMLexport void caml_print_exception_backtrace(void) } } -/* Convert the backtrace to a data structure usable from Caml */ +/* Convert the backtrace to a data structure usable from OCaml */ CAMLprim value caml_get_exception_backtrace(value unit) { diff --git a/byterun/backtrace.h b/byterun/backtrace.h index 2d9c202e..23c72e6c 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/callback.c b/byterun/callback.c index d76cf108..c7fc7722 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -13,7 +13,7 @@ /* $Id$ */ -/* Callbacks from C to Caml */ +/* Callbacks from C to OCaml */ #include #include "callback.h" @@ -195,7 +195,7 @@ CAMLexport value caml_callbackN (value closure, int narg, value args[]) return res; } -/* Naming of Caml values */ +/* Naming of OCaml values */ struct named_value { value val; diff --git a/byterun/callback.h b/byterun/callback.h index ffa6cf3b..dd094c4d 100644 --- a/byterun/callback.h +++ b/byterun/callback.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -13,7 +13,7 @@ /* $Id$ */ -/* Callbacks from C to Caml */ +/* Callbacks from C to OCaml */ #ifndef CAML_CALLBACK_H #define CAML_CALLBACK_H @@ -23,6 +23,10 @@ #endif #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern value caml_callback (value closure, value arg); CAMLextern value caml_callback2 (value closure, value arg1, value arg2); CAMLextern value caml_callback3 (value closure, value arg1, value arg2, @@ -46,4 +50,8 @@ CAMLextern void caml_startup (char ** argv); CAMLextern int caml_callback_depth; +#ifdef __cplusplus +} +#endif + #endif diff --git a/byterun/compact.c b/byterun/compact.c index ba1042fb..b3c75f33 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ @@ -144,7 +144,7 @@ static char *compact_allocate (mlsize_t size) return adr; } -void caml_compact_heap (void) +static void do_compaction (void) { char *ch, *chend; Assert (caml_gc_phase == Phase_idle); @@ -395,6 +395,58 @@ void caml_compact_heap (void) uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */ +void caml_compact_heap (void) +{ + uintnat target_size; + + do_compaction (); + /* Compaction may fail to shrink the heap to a reasonable size + because it deals in complete chunks: if a very large chunk + is at the beginning of the heap, everything gets moved to + it and it is not freed. + + In that case, we allocate a new chunk of the desired heap + size, chain it at the beginning of the heap (thus pretending + its address is smaller), and launch a second compaction. + This will move all data to this new chunk and free the + very large chunk. + + See PR#5389 + */ + /* We compute: + freewords = caml_fl_cur_size (exact) + heapsize = caml_heap_size (exact) + usedwords = heap_size - freewords + target_size = usedwords * (1 + caml_percent_free / 100) + + We recompact if target_size < heap_size / 2 + */ + target_size = (caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size)) + * (100 + caml_percent_free) / 100; + target_size = caml_round_heap_chunk_size (target_size); + if (target_size < caml_stat_heap_size / 2){ + char *chunk; + + /* round it up to a page size */ + chunk = caml_alloc_for_heap (target_size); + if (chunk == NULL) return; + caml_make_free_blocks ((value *) chunk, + Wsize_bsize (Chunk_size (chunk)), 0); + if (caml_page_table_add (In_heap, chunk, chunk + Chunk_size (chunk)) != 0){ + caml_free_for_heap (chunk); + return; + } + Chunk_next (chunk) = caml_heap_start; + caml_heap_start = chunk; + caml_stat_heap_size += Chunk_size (chunk); + if (caml_stat_heap_size > caml_stat_top_heap_size){ + caml_stat_top_heap_size = caml_stat_heap_size; + } + do_compaction (); + Assert (Chunk_next (caml_heap_start) == NULL); + } +} + void caml_compact_heap_maybe (void) { /* Estimated free words in the heap: @@ -408,7 +460,7 @@ void caml_compact_heap_maybe (void) float fw, fp; Assert (caml_gc_phase == Phase_idle); if (caml_percent_max >= 1000000) return; - if (caml_stat_major_collections < 3 || caml_stat_heap_chunks < 3) return; + if (caml_stat_major_collections < 3) return; fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; if (fw < 0) fw = caml_fl_cur_size; diff --git a/byterun/compact.h b/byterun/compact.h index a4ef4cb1..949a2766 100644 --- a/byterun/compact.h +++ b/byterun/compact.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/compare.c b/byterun/compare.c index 75163075..c0ee65a2 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -106,7 +106,7 @@ static intnat compare_val(value v1, value v2, int total) /* Subtraction above cannot overflow and cannot result in UNORDERED */ if (Is_in_value_area(v2)) { switch (Tag_val(v2)) { - case Forward_tag: + case Forward_tag: v2 = Forward_val(v2); continue; case Custom_tag: { diff --git a/byterun/compare.h b/byterun/compare.h index dc392ff3..c73a49a4 100644 --- a/byterun/compare.h +++ b/byterun/compare.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ /* */ diff --git a/byterun/compatibility.h b/byterun/compatibility.h index 5c21774e..429d2275 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ diff --git a/byterun/config.h b/byterun/config.h index 22abe871..b36b73c9 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/custom.c b/byterun/custom.c index 24281db8..b2d7b520 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ diff --git a/byterun/custom.h b/byterun/custom.h index 51fabed9..c6abad8e 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ @@ -43,6 +43,11 @@ struct custom_operations { #define Custom_ops_val(v) (*((struct custom_operations **) (v))) +#ifdef __cplusplus +extern "C" { +#endif + + CAMLextern value caml_alloc_custom(struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem, /*resources consumed*/ @@ -61,4 +66,8 @@ extern struct custom_operations * extern void caml_init_custom_operations(void); /* */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_CUSTOM_H */ diff --git a/byterun/debugger.c b/byterun/debugger.c index f9689126..a114b46c 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -21,6 +21,7 @@ #include +#include "alloc.h" #include "config.h" #include "debugger.h" #include "misc.h" @@ -28,6 +29,7 @@ int caml_debugger_in_use = 0; uintnat caml_event_count; int caml_debugger_fork_mode = 1; /* parent by default */ +value marshal_flags = Val_emptylist; #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE) @@ -162,6 +164,11 @@ void caml_debugger_init(void) struct hostent * host; int n; + caml_register_global_root(&marshal_flags); + marshal_flags = caml_alloc(2, Tag_cons); + Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */ + Store_field(marshal_flags, 1, Val_emptylist); + address = getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; dbg_addr = address; @@ -230,7 +237,7 @@ static void safe_output_value(struct channel *chan, value val) saved_external_raise = caml_external_raise; if (sigsetjmp(raise_buf.buf, 0) == 0) { caml_external_raise = &raise_buf; - caml_output_val(chan, val, Val_unit); + caml_output_val(chan, val, marshal_flags); } else { /* Send wrong magic number, will cause [caml_input_value] to fail */ caml_really_putblock(chan, "\000\000\000\000", 4); diff --git a/byterun/debugger.h b/byterun/debugger.h index 57a58f1c..a9501abf 100644 --- a/byterun/debugger.h +++ b/byterun/debugger.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 7df594db..ddd406ba 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/dynlink.h b/byterun/dynlink.h index ad4bfbad..b1d14d84 100644 --- a/byterun/dynlink.h +++ b/byterun/dynlink.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/exec.h b/byterun/exec.h index 1abfa455..88cf6d28 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/extern.c b/byterun/extern.c index 89e89f00..b95a5054 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -24,6 +24,7 @@ #include "gc.h" #include "intext.h" #include "io.h" +#include "md5.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" @@ -56,6 +57,7 @@ static struct trail_entry * extern_trail_cur, * extern_trail_limit; static void extern_out_of_memory(void); static void extern_invalid_argument(char *msg); +static struct code_fragment * extern_find_code(char *addr); /* Initialize the trail */ @@ -289,6 +291,7 @@ static void writecode64(int code, intnat val) static void extern_rec(value v) { + struct code_fragment * cf; tailcall: if (Is_long(v)) { intnat n = Long_val(v); @@ -438,12 +441,11 @@ static void extern_rec(value v) } } } - else if ((char *) v >= caml_code_area_start && - (char *) v < caml_code_area_end) { + else if ((cf = extern_find_code((char *) v)) != NULL) { if (!extern_closures) extern_invalid_argument("output_value: functional value"); - writecode32(CODE_CODEPOINTER, (char *) v - caml_code_area_start); - writeblock((char *) caml_code_checksum(), 16); + writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start); + writeblock((char *) cf->digest, 16); } else { extern_invalid_argument("output_value: abstract value (outside heap)"); } @@ -724,3 +726,20 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len) } #endif } + +/* Find where a code pointer comes from */ + +static struct code_fragment * extern_find_code(char *addr) +{ + int i; + for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { + struct code_fragment * cf = caml_code_fragments_table.contents[i]; + if (! cf->digest_computed) { + caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start); + cf->digest_computed = 1; + } + if (cf->code_start <= addr && addr < cf->code_end) return cf; + } + return NULL; +} + diff --git a/byterun/fail.c b/byterun/fail.c index aceb253b..b0beaa43 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -168,3 +168,9 @@ void caml_init_exceptions(void) out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); caml_register_global_root(&out_of_memory_bucket.exn); } + +int caml_is_special_exception(value exn) { + return exn == Field(caml_global_data, MATCH_FAILURE_EXN) + || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) + || exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN); +} diff --git a/byterun/fail.h b/byterun/fail.h index f092c811..ee05eb7f 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -54,9 +54,14 @@ struct longjmp_buffer { CAMLextern struct longjmp_buffer * caml_external_raise; extern value caml_exn_bucket; +int caml_is_special_exception(value exn); /* */ +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern void caml_raise (value bucket) Noreturn; CAMLextern void caml_raise_constant (value tag) Noreturn; CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; @@ -74,4 +79,8 @@ CAMLextern void caml_init_exceptions (void); CAMLextern void caml_array_bound_error (void) Noreturn; CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; +#ifdef __cplusplus +} +#endif + #endif /* CAML_FAIL_H */ diff --git a/byterun/finalise.c b/byterun/finalise.c index bc7996d5..9a93084a 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ diff --git a/byterun/finalise.h b/byterun/finalise.h index ec656f4f..e41baa32 100644 --- a/byterun/finalise.h +++ b/byterun/finalise.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ diff --git a/byterun/fix_code.c b/byterun/fix_code.c index b252efd5..27e715be 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -24,6 +24,7 @@ #include "debugger.h" #include "fix_code.h" #include "instruct.h" +#include "intext.h" #include "md5.h" #include "memory.h" #include "misc.h" @@ -40,15 +41,21 @@ unsigned char caml_code_md5[16]; void caml_load_code(int fd, asize_t len) { int i; - struct MD5Context ctx; + struct code_fragment * cf; caml_code_size = len; caml_start_code = (code_t) caml_stat_alloc(caml_code_size); if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size) caml_fatal_error("Fatal error: truncated bytecode file.\n"); - caml_MD5Init(&ctx); - caml_MD5Update(&ctx, (unsigned char *) caml_start_code, caml_code_size); - caml_MD5Final(caml_code_md5, &ctx); + /* Register the code in the table of code fragments */ + cf = caml_stat_alloc(sizeof(struct code_fragment)); + cf->code_start = (char *) caml_start_code; + cf->code_end = (char *) caml_start_code + caml_code_size; + caml_md5_block(cf->digest, caml_start_code, caml_code_size); + cf->digest_computed = 1; + caml_ext_table_init(&caml_code_fragments_table, 8); + caml_ext_table_add(&caml_code_fragments_table, cf); + /* Prepare the code for execution */ #ifdef ARCH_BIG_ENDIAN caml_fixup_endianness(caml_start_code, caml_code_size); #endif diff --git a/byterun/fix_code.h b/byterun/fix_code.h index f6e9e3b7..d0887c03 100644 --- a/byterun/fix_code.h +++ b/byterun/fix_code.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -26,7 +26,6 @@ extern code_t caml_start_code; extern asize_t caml_code_size; extern unsigned char * caml_saved_code; -extern unsigned char caml_code_md5[16]; void caml_load_code (int fd, asize_t len); void caml_fixup_endianness (code_t code, asize_t len); diff --git a/byterun/floats.c b/byterun/floats.c index d1d178a3..f708d70f 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -28,6 +28,12 @@ #include "reverse.h" #include "stacks.h" +#ifdef _MSC_VER +#include +#define isnan _isnan +#define isfinite _finite +#endif + #ifdef ARCH_ALIGN_DOUBLE CAMLexport double caml_Double_val(value val) @@ -77,7 +83,11 @@ CAMLprim value caml_format_float(value fmt, value arg) char * p; char * dest; value res; + double d = Double_val(arg); +#ifdef HAS_BROKEN_PRINTF + if (isfinite(d)) { +#endif prec = MAX_DIGITS; for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { @@ -98,11 +108,30 @@ CAMLprim value caml_format_float(value fmt, value arg) } else { dest = caml_stat_alloc(prec); } - sprintf(dest, String_val(fmt), Double_val(arg)); + sprintf(dest, String_val(fmt), d); res = caml_copy_string(dest); if (dest != format_buffer) { caml_stat_free(dest); } +#ifdef HAS_BROKEN_PRINTF + } else { + if (isnan(d)) + { + res = caml_copy_string("nan"); + } + else + { + if (d > 0) + { + res = caml_copy_string("inf"); + } + else + { + res = caml_copy_string("-inf"); + } + } + } +#endif return res; } @@ -326,12 +355,32 @@ CAMLprim value caml_ceil_float(value f) return caml_copy_double(ceil(Double_val(f))); } +CAMLexport double caml_hypot(double x, double y) +{ +#ifdef HAS_C99_FLOAT_OPS + return hypot(x, y); +#else + double tmp, ratio; + if (x != x) return x; /* NaN */ + if (y != y) return y; /* NaN */ + x = fabs(x); y = fabs(y); + if (x < y) { tmp = x; x = y; y = tmp; } + if (x == 0.0) return 0.0; + ratio = y / x; + return x * sqrt(1.0 + ratio * ratio); +#endif +} + +CAMLprim value caml_hypot_float(value f, value g) +{ + return caml_copy_double(caml_hypot(Double_val(f), Double_val(g))); +} + /* These emulations of expm1() and log1p() are due to William Kahan. See http://www.plunk.org/~hatch/rightway.php */ - CAMLexport double caml_expm1(double x) { -#ifdef HAS_EXPM1_LOG1P +#ifdef HAS_C99_FLOAT_OPS return expm1(x); #else double u = exp(x); @@ -345,7 +394,7 @@ CAMLexport double caml_expm1(double x) CAMLexport double caml_log1p(double x) { -#ifdef HAS_EXPM1_LOG1P +#ifdef HAS_C99_FLOAT_OPS return log1p(x); #else double u = 1. + x; @@ -366,6 +415,34 @@ CAMLprim value caml_log1p_float(value f) return caml_copy_double(caml_log1p(Double_val(f))); } +union double_as_two_int32 { + double d; +#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) + struct { uint32 h; uint32 l; } i; +#else + struct { uint32 l; uint32 h; } i; +#endif +}; + +CAMLexport double caml_copysign(double x, double y) +{ +#ifdef HAS_C99_FLOAT_OPS + return copysign(x, y); +#else + union double_as_two_int32 ux, uy; + ux.d = x; + uy.d = y; + ux.i.h &= 0x7FFFFFFFU; + ux.i.h |= (uy.i.h & 0x80000000U); + return ux.d; +#endif +} + +CAMLprim value caml_copysign_float(value f, value g) +{ + return caml_copy_double(caml_copysign(Double_val(f), Double_val(g))); +} + CAMLprim value caml_eq_float(value f, value g) { return Val_bool(Double_val(f) == Double_val(g)); @@ -429,14 +506,7 @@ CAMLprim value caml_classify_float(value vd) return Val_int(FP_normal); } #else - union { - double d; -#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; -#else - struct { uint32 l; uint32 h; } i; -#endif - } u; + union double_as_two_int32 u; uint32 h, l; u.d = Double_val(vd); diff --git a/byterun/freelist.c b/byterun/freelist.c index ab1d458b..f3bb4a8e 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/freelist.h b/byterun/freelist.h index 8db168e9..b4285d95 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/gc.h b/byterun/gc.h index 50d9945a..4f67ed90 100644 --- a/byterun/gc.h +++ b/byterun/gc.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 9a2e0b08..b5c43667 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ @@ -133,7 +133,7 @@ static value heap_stats (int returnstats) header_t cur_hd; #ifdef DEBUG - caml_gc_message (-1, "### O'Caml runtime: heap check ###\n", 0); + caml_gc_message (-1, "### OCaml runtime: heap check ###\n", 0); #endif while (chunk != NULL){ diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h index 205636d5..4dba74fa 100644 --- a/byterun/gc_ctrl.h +++ b/byterun/gc_ctrl.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/globroots.c b/byterun/globroots.c index acac1e21..513b7be5 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/globroots.h b/byterun/globroots.h index 4dee35f2..97a1edab 100644 --- a/byterun/globroots.h +++ b/byterun/globroots.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/hash.c b/byterun/hash.c index c981768d..26a1bf59 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -15,11 +15,267 @@ /* The generic hashing primitive */ -/* The interface of this file is in "mlvalues.h" */ +/* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) + and in "hash.h" (for the other exported functions). */ #include "mlvalues.h" #include "custom.h" #include "memory.h" +#include "hash.h" + +#ifdef ARCH_INT64_TYPE +#include "int64_native.h" +#else +#include "int64_emul.h" +#endif + +/* The new implementation, based on MurmurHash 3, + http://code.google.com/p/smhasher/ */ + +#define ROTL32(x,n) ((x) << n | (x) >> (32-n)) + +#define MIX(h,d) \ + d *= 0xcc9e2d51; \ + d = ROTL32(d, 15); \ + d *= 0x1b873593; \ + h ^= d; \ + h = ROTL32(h, 13); \ + h = h * 5 + 0xe6546b64; + +#define FINAL_MIX(h) \ + h ^= h >> 16; \ + h *= 0x85ebca6b; \ + h ^= h >> 13; \ + h *= 0xc2b2ae35; \ + h ^= h >> 16; + +CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) +{ + MIX(h, d); + return h; +} + +/* Mix a platform-native integer. */ + +CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) +{ + uint32 n; +#ifdef ARCH_SIXTYFOUR + /* Mix the low 32 bits and the high 32 bits, in a way that preserves + 32/64 compatibility: we want n = (uint32) d + if d is in the range [-2^31, 2^31-1]. */ + n = (d >> 32) ^ (d >> 63) ^ d; + /* If 0 <= d < 2^31: d >> 32 = 0 d >> 63 = 0 + If -2^31 <= d < 0: d >> 32 = -1 d >> 63 = -1 + In both cases, n = (uint32) d. */ +#else + n = d; +#endif + MIX(h, n); + return h; +} + +/* Mix a 64-bit integer. */ + +CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) +{ + uint32 hi, lo; + + I64_split(d, hi, lo); + MIX(h, lo); + MIX(h, hi); + return h; +} + +/* Mix a double-precision float. + Treats +0.0 and -0.0 identically. + Treats all NaNs identically. +*/ + +CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) +{ + union { + double d; +#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) + struct { uint32 h; uint32 l; } i; +#else + struct { uint32 l; uint32 h; } i; +#endif + } u; + uint32 h, l; + /* Convert to two 32-bit halves */ + u.d = d; + h = u.i.h; l = u.i.l; + /* Normalize NaNs */ + if ((h & 0x7FF00000) == 0x7FF00000 && (l | (h & 0xFFFFF)) != 0) { + h = 0x7FF00000; + l = 0x00000001; + } + /* Normalize -0 into +0 */ + else if (h == 0x80000000 && l == 0) { + h = 0; + } + MIX(hash, l); + MIX(hash, h); + return hash; +} + +/* Mix a single-precision float. + Treats +0.0 and -0.0 identically. + Treats all NaNs identically. +*/ + +CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) +{ + union { + float f; + uint32 i; + } u; + uint32 n; + /* Convert to int32 */ + u.f = d; n = u.i; + /* Normalize NaNs */ + if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) { + n = 0x7F800001; + } + /* Normalize -0 into +0 */ + else if (n == 0x80000000) { + n = 0; + } + MIX(hash, n); + return hash; +} + +/* Mix an OCaml string */ + +CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) +{ + mlsize_t len = caml_string_length(s); + mlsize_t i; + uint32 w; + + /* Mix by 32-bit blocks (little-endian) */ + for (i = 0; i + 4 <= len; i += 4) { +#ifdef ARCH_BIG_ENDIAN + w = Byte_u(s, i) + | (Byte_u(s, i+1) << 8) + | (Byte_u(s, i+2) << 16) + | (Byte_u(s, i+3) << 24); +#else + w = *((uint32 *) &Byte_u(s, i)); +#endif + MIX(h, w); + } + /* Finish with up to 3 bytes */ + w = 0; + switch (len & 3) { + case 3: w = Byte_u(s, i+2) << 16; /* fallthrough */ + case 2: w |= Byte_u(s, i+1) << 8; /* fallthrough */ + case 1: w |= Byte_u(s, i); + MIX(h, w); + default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */ + } + /* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */ + h ^= (uint32) len; + return h; +} + +/* Maximal size of the queue used for breadth-first traversal. */ +#define HASH_QUEUE_SIZE 256 + +/* The generic hash function */ + +CAMLprim value caml_hash(value count, value limit, value seed, value obj) +{ + value queue[HASH_QUEUE_SIZE]; /* Queue of values to examine */ + intnat rd; /* Position of first value in queue */ + intnat wr; /* One past position of last value in queue */ + intnat sz; /* Max number of values to put in queue */ + intnat num; /* Max number of meaningful values to see */ + uint32 h; /* Rolling hash */ + value v; + mlsize_t i, len; + + sz = Long_val(limit); + if (sz < 0 || sz > HASH_QUEUE_SIZE) sz = HASH_QUEUE_SIZE; + num = Long_val(count); + h = Int_val(seed); + queue[0] = obj; rd = 0; wr = 1; + + while (rd < wr && num > 0) { + v = queue[rd++]; + again: + if (Is_long(v)) { + h = caml_hash_mix_intnat(h, v); + num--; + } + else if (Is_in_value_area(v)) { + switch (Tag_val(v)) { + case String_tag: + h = caml_hash_mix_string(h, v); + num--; + break; + case Double_tag: + h = caml_hash_mix_double(h, Double_val(v)); + num--; + break; + case Double_array_tag: + for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { + h = caml_hash_mix_double(h, Double_field(v, i)); + num--; + if (num < 0) break; + } + break; + case Abstract_tag: + /* Block contents unknown. Do nothing. */ + break; + case Infix_tag: + /* Mix in the offset to distinguish different functions from + the same mutually-recursive definition */ + h = caml_hash_mix_uint32(h, Infix_offset_val(v)); + v = v - Infix_offset_val(v); + goto again; + case Forward_tag: + v = Forward_val(v); + goto again; + case Object_tag: + h = caml_hash_mix_intnat(h, Oid_val(v)); + num--; + break; + case Custom_tag: + /* If no hashing function provided, do nothing. */ + /* Only use low 32 bits of custom hash, for 32/64 compatibility */ + if (Custom_ops_val(v)->hash != NULL) { + uint32 n = (uint32) Custom_ops_val(v)->hash(v); + h = caml_hash_mix_uint32(h, n); + num--; + } + break; + default: + /* Mix in the tag and size, but do not count this towards [num] */ + h = caml_hash_mix_uint32(h, Whitehd_hd(Hd_val(v))); + /* Copy fields into queue, not exceeding the total size [sz] */ + for (i = 0, len = Wosize_val(v); i < len; i++) { + if (wr >= sz) break; + queue[wr++] = Field(v, i); + } + break; + } + } else { + /* v is a pointer outside the heap, probably a code pointer. + Shall we count it? Let's say yes by compatibility with old code. */ + h = caml_hash_mix_intnat(h, v); + num--; + } + } + /* Final mixing of bits */ + FINAL_MIX(h); + /* Fold result to the range [0, 2^30-1] so that it is a nonnegative + OCaml integer both on 32 and 64-bit platforms. */ + return Val_int(h & 0x3FFFFFFFU); +} + +/* The old implementation */ static uintnat hash_accu; static intnat hash_univ_limit, hash_univ_count; diff --git a/byterun/hash.h b/byterun/hash.h new file mode 100644 index 00000000..22b051ac --- /dev/null +++ b/byterun/hash.h @@ -0,0 +1,32 @@ +/***********************************************************************/ +/* */ +/* 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 GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +/* Auxiliary functions for custom hash functions */ + +#ifndef CAML_HASH_H +#define CAML_HASH_H + +#include "mlvalues.h" + +CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); +CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); +CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); +CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); +CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); +CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); + + +#endif + diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 3afdc954..1c329daa 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h index c1ca4a7e..686b9e4e 100644 --- a/byterun/instrtrace.h +++ b/byterun/instrtrace.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/instruct.h b/byterun/instruct.h index c45d4ea2..92f22850 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index ec4ed0be..ad48584d 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -27,6 +27,8 @@ #define I64_literal(hi,lo) { lo, hi } #endif +#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) + /* Unsigned comparison */ static int I64_ucompare(uint64 x, uint64 y) { diff --git a/byterun/int64_format.h b/byterun/int64_format.h index b9ae9104..398357a6 100644 --- a/byterun/int64_format.h +++ b/byterun/int64_format.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -52,7 +52,7 @@ static void I64_format(char * buffer, char * fmt, int64 x) case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': width = atoi(p); - while (*p >= '0' && *p <= '9') p++; + while (p[1] >= '0' && p[1] <= '9') p++; break; case 'd': case 'i': signedconv = 1; /* fallthrough */ diff --git a/byterun/int64_native.h b/byterun/int64_native.h index 9c079097..9aa45e3c 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -21,6 +21,7 @@ #define CAML_INT64_NATIVE_H #define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) +#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) #define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) #define I64_neg(x) (-(x)) diff --git a/byterun/intern.c b/byterun/intern.c index f4421146..8b424656 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -18,12 +18,15 @@ /* The interface of this file is "intext.h" */ #include +#include #include "alloc.h" +#include "callback.h" #include "custom.h" #include "fail.h" #include "gc.h" #include "intext.h" #include "io.h" +#include "md5.h" #include "memory.h" #include "mlvalues.h" #include "misc.h" @@ -63,6 +66,14 @@ static value intern_block; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ +static value * camlinternaloo_last_id = NULL; +/* Pointer to a reference holding the last object id. + -1 means not available (CamlinternalOO not loaded). */ + +static char * intern_resolve_code_pointer(unsigned char digest[16], + asize_t offset); +static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn; + #define Sign_extend_shift ((sizeof(intnat) - 1) * 8) #define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift) @@ -119,8 +130,9 @@ static void intern_rec(value *dest) value v, clos; asize_t ofs; header_t header; - char cksum[16]; + unsigned char digest[16]; struct custom_operations * ops; + char * codeptr; tailcall: code = read8u(); @@ -139,6 +151,22 @@ static void intern_rec(value *dest) dest = (value *) (intern_dest + 1); *intern_dest = Make_header(size, tag, intern_color); intern_dest += 1 + size; + /* For objects, we need to freshen the oid */ + if (tag == Object_tag && camlinternaloo_last_id != (value*)-1) { + intern_rec(dest++); + intern_rec(dest++); + if (camlinternaloo_last_id == NULL) + camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); + if (camlinternaloo_last_id == NULL) + camlinternaloo_last_id = (value*)-1; + else { + value id = Field(*camlinternaloo_last_id,0); + Field(dest,-1) = id; + Field(*camlinternaloo_last_id,0) = id + 2; + } + size -= 2; + if (size == 0) return; + } for(/*nothing*/; size > 1; size--, dest++) intern_rec(dest); goto tailcall; @@ -288,12 +316,20 @@ static void intern_rec(value *dest) goto read_double_array; case CODE_CODEPOINTER: ofs = read32u(); - readblock(cksum, 16); - if (memcmp(cksum, caml_code_checksum(), 16) != 0) { - intern_cleanup(); - caml_failwith("input_value: code mismatch"); + readblock(digest, 16); + codeptr = intern_resolve_code_pointer(digest, ofs); + if (codeptr != NULL) { + v = (value) codeptr; + } else { + value * function_placeholder = + caml_named_value ("Debugger.function_placeholder"); + if (function_placeholder != NULL) { + v = *function_placeholder; + } else { + intern_cleanup(); + intern_bad_code_pointer(digest); + } } - v = (value) (caml_code_area_start + ofs); break; case CODE_INFIXPOINTER: ofs = read32u(); @@ -328,6 +364,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) { mlsize_t wosize; + if (camlinternaloo_last_id == (value*)-1) + camlinternaloo_last_id = NULL; /* Reset ignore flag */ if (whsize == 0) { intern_obj_table = NULL; intern_extra_block = NULL; @@ -551,40 +589,39 @@ CAMLprim value caml_marshal_data_size(value buff, value ofs) return Val_long(block_len); } -/* Return an MD5 checksum of the code area */ - -#ifdef NATIVE_CODE - -#include "md5.h" +/* Resolution of code pointers */ -unsigned char * caml_code_checksum(void) +static char * intern_resolve_code_pointer(unsigned char digest[16], + asize_t offset) { - static unsigned char checksum[16]; - static int checksum_computed = 0; - - if (! checksum_computed) { - struct MD5Context ctx; - caml_MD5Init(&ctx); - caml_MD5Update(&ctx, - (unsigned char *) caml_code_area_start, - caml_code_area_end - caml_code_area_start); - caml_MD5Final(checksum, &ctx); - checksum_computed = 1; + int i; + for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { + struct code_fragment * cf = caml_code_fragments_table.contents[i]; + if (! cf->digest_computed) { + caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start); + cf->digest_computed = 1; + } + if (memcmp(digest, cf->digest, 16) == 0) { + if (cf->code_start + offset < cf->code_end) + return cf->code_start + offset; + else + return NULL; + } } - return checksum; + return NULL; } -#else - -#include "fix_code.h" - -unsigned char * caml_code_checksum(void) +static void intern_bad_code_pointer(unsigned char digest[16]) { - return caml_code_md5; + 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", + digest[0], digest[1], digest[2], digest[3], + digest[4], digest[5], digest[6], digest[7], + digest[8], digest[9], digest[10], digest[11], + digest[12], digest[13], digest[14], digest[15]); + caml_failwith(msg); } -#endif - /* Functions for writing user-defined marshallers */ CAMLexport int caml_deserialize_uint_1(void) diff --git a/byterun/interp.c b/byterun/interp.c index 7bcdf7ac..cbec02a5 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/interp.h b/byterun/interp.h index 9eb73394..7c3d26f2 100644 --- a/byterun/interp.h +++ b/byterun/interp.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/intext.h b/byterun/intext.h index b757d171..b287e5cd 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -81,6 +81,10 @@ void caml_output_val (struct channel * chan, value v, value flags); /* */ +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern void caml_output_value_to_malloc(value v, value flags, /*out*/ char ** buf, /*out*/ intnat * len); @@ -100,7 +104,7 @@ value caml_input_val (struct channel * chan); /* */ CAMLextern value caml_input_val_from_string (value str, intnat ofs); - /* Read a structured value from the Caml string [str], starting + /* Read a structured value from the OCaml string [str], starting at offset [ofs]. */ CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); /* Read a structured value from a malloced buffer. [data] points @@ -147,16 +151,20 @@ CAMLextern void caml_deserialize_error(char * msg); /* */ /* Auxiliary stuff for sending code pointers */ -unsigned char * caml_code_checksum (void); -#ifndef NATIVE_CODE -#include "fix_code.h" -#define caml_code_area_start ((char *) caml_start_code) -#define caml_code_area_end ((char *) caml_start_code + caml_code_size) -#else -extern char * caml_code_area_start, * caml_code_area_end; -#endif +struct code_fragment { + char * code_start; + char * code_end; + unsigned char digest[16]; + char digest_computed; +}; + +struct ext_table caml_code_fragments_table; /* */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_INTEXT_H */ diff --git a/byterun/ints.c b/byterun/ints.c index 51a9a3b3..34b5db23 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -142,7 +142,7 @@ static char * parse_format(value fmt, char lastletter; mlsize_t len, len_suffix; - /* Copy Caml format fmt to format_string, + /* Copy OCaml format fmt to format_string, adding the suffix before the last letter of the format */ len = caml_string_length(fmt); len_suffix = strlen(suffix); @@ -227,7 +227,8 @@ CAMLexport struct custom_operations caml_int32_ops = { int32_cmp, int32_hash, int32_serialize, - int32_deserialize + int32_deserialize, + custom_compare_ext_default }; CAMLexport value caml_copy_int32(int32 i) @@ -381,7 +382,11 @@ static int int64_cmp(value v1, value v2) static intnat int64_hash(value v) { - return I64_to_intnat(Int64_val(v)); + int64 x = Int64_val(v); + uint32 lo, hi; + + I64_split(x, hi, lo); + return hi ^ lo; } static void int64_serialize(value v, uintnat * wsize_32, @@ -410,7 +415,8 @@ CAMLexport struct custom_operations caml_int64_ops = { int64_cmp, int64_hash, int64_serialize, - int64_deserialize + int64_deserialize, + custom_compare_ext_default }; CAMLexport value caml_copy_int64(int64 i) @@ -606,7 +612,14 @@ static int nativeint_cmp(value v1, value v2) static intnat nativeint_hash(value v) { - return Nativeint_val(v); + intnat n = Nativeint_val(v); +#ifdef ARCH_SIXTYFOUR + /* 32/64 bits compatibility trick. See explanations in file "hash.c", + function caml_hash_mix_intnat. */ + return (n >> 32) ^ (n >> 63) ^ n; +#else + return n; +#endif } static void nativeint_serialize(value v, uintnat * wsize_32, @@ -654,7 +667,8 @@ CAMLexport struct custom_operations caml_nativeint_ops = { nativeint_cmp, nativeint_hash, nativeint_serialize, - nativeint_deserialize + nativeint_deserialize, + custom_compare_ext_default }; CAMLexport value caml_copy_nativeint(intnat i) diff --git a/byterun/io.c b/byterun/io.c index e7c7f048..600887a8 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -117,7 +117,7 @@ CAMLexport file_offset caml_channel_size(struct channel *channel) file_offset end; int fd; - /* We extract data from [channel] before dropping the Caml lock, in case + /* We extract data from [channel] before dropping the OCaml lock, in case someone else touches the block. */ fd = channel->fd; offset = channel->offset; @@ -411,7 +411,7 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel) return (p - channel->curr); } -/* Caml entry points for the I/O functions. Wrap struct channel * +/* OCaml entry points for the I/O functions. Wrap struct channel * objects into a heap-allocated object. Perform locking and unlocking around the I/O operations. */ /* FIXME CAMLexport, but not in io.h exported for Cash ? */ @@ -431,13 +431,19 @@ static int compare_channel(value vchan1, value vchan2) return (chan1 == chan2) ? 0 : (chan1 < chan2) ? -1 : 1; } +static intnat hash_channel(value vchan) +{ + return (intnat) (Channel(vchan)); +} + static struct custom_operations channel_operations = { "_chan", caml_finalize_channel, compare_channel, - custom_hash_default, + hash_channel, custom_serialize_default, - custom_deserialize_default + custom_deserialize_default, + custom_compare_ext_default }; CAMLexport value caml_alloc_channel(struct channel *chan) diff --git a/byterun/io.h b/byterun/io.h index d02a5a72..89a85380 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -22,7 +22,7 @@ #include "mlvalues.h" #ifndef IO_BUFFER_SIZE -#define IO_BUFFER_SIZE 4096 +#define IO_BUFFER_SIZE 65536 #endif #if defined(_WIN32) diff --git a/byterun/lexing.c b/byterun/lexing.c index 6e74795c..cb763bce 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/main.c b/byterun/main.c index e6afb1b3..63355840 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/major_gc.c b/byterun/major_gc.c index b9ec8cbf..aeb192fd 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 12f88067..42731278 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/md5.c b/byterun/md5.c index d0b6e5e4..a2125127 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -68,6 +68,15 @@ CAMLprim value caml_md5_chan(value vchan, value len) CAMLreturn (res); } +CAMLexport void caml_md5_block(unsigned char digest[16], + void * data, uintnat len) +{ + struct MD5Context ctx; + caml_MD5Init(&ctx); + caml_MD5Update(&ctx, data, len); + caml_MD5Final(digest, &ctx); +} + /* * This code implements the MD5 message-digest algorithm. * The algorithm is due to Ron Rivest. This code was diff --git a/byterun/md5.h b/byterun/md5.h index b92b02ad..0c4239e5 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -24,6 +24,8 @@ CAMLextern value caml_md5_string (value str, value ofs, value len); CAMLextern value caml_md5_chan (value vchan, value len); +CAMLextern void caml_md5_block(unsigned char digest[16], + void * data, uintnat len); struct MD5Context { uint32 buf[4]; diff --git a/byterun/memory.c b/byterun/memory.c index bc4c88df..b99825d1 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ @@ -255,6 +255,8 @@ void caml_free_for_heap (char *mem) caller. All other blocks must have the color [caml_allocation_color(m)]. The caller must update [caml_allocated_words] if applicable. Return value: 0 if no error; -1 in case of error. + + See also: caml_compact_heap, which duplicates most of this function. */ int caml_add_to_heap (char *m) { @@ -353,7 +355,7 @@ void caml_shrink_heap (char *chunk) { char **cp; - /* Never deallocate the first block, because caml_heap_start is both the + /* Never deallocate the first chunk, because caml_heap_start is both the first block and the base address for page numbers, and we don't want to shift the page table, it's too messy (see above). It will never happen anyway, because of the way compaction works. diff --git a/byterun/memory.h b/byterun/memory.h index f8fb8ca2..69f5ff91 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ @@ -30,6 +30,11 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + + CAMLextern value caml_alloc_shr (mlsize_t, tag_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t); @@ -102,7 +107,7 @@ int caml_page_table_initialize(mlsize_t bytesize); CAMLassert ((tag_t) (tag) < 256); \ CAMLassert ((wosize) <= Max_young_wosize); \ caml_young_ptr -= Bhsize_wosize (wosize); \ - if (caml_young_ptr < caml_young_limit){ \ + if (caml_young_ptr < caml_young_start){ \ caml_young_ptr += Bhsize_wosize (wosize); \ Setup_for_gc; \ caml_minor_collection (); \ @@ -168,15 +173,15 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ If you need local variables of type [value], declare them with one or more calls to the [CAMLlocal] macros at the beginning of the - function. Use [CAMLlocalN] (at the beginning of the function) to - declare an array of [value]s. + function, after the call to CAMLparam. Use [CAMLlocalN] (at the + beginning of the function) to declare an array of [value]s. Your function may raise an exception or return a [value] with the [CAMLreturn] macro. Its argument is simply the [value] returned by your function. Do NOT directly return a [value] with the [return] keyword. If your function returns void, use [CAMLreturn0]. - All the identifiers beginning with "caml__" are reserved by Caml. + All the identifiers beginning with "caml__" are reserved by OCaml. Do not use them for anything (local or global variables, struct or union tags, macros, etc.) */ @@ -341,7 +346,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ It must contain all values in C local variables and function parameters at the time the minor GC is called. Usage: - After initialising your local variables to legal Caml values, but before + After initialising your local variables to legal OCaml values, but before calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where v1 ... vn are your variables of type [value] that you want to be updated across allocations. @@ -435,7 +440,7 @@ CAMLextern void caml_remove_global_root (value *); the value of this variable, it must do so by calling [caml_modify_generational_global_root]. The [value *] pointer passed to [caml_register_generational_global_root] must contain - a valid Caml value before the call. + a valid OCaml value before the call. In return for these constraints, scanning of memory roots during minor collection is made more efficient. */ @@ -456,4 +461,8 @@ CAMLextern void caml_remove_generational_global_root (value *); CAMLextern void caml_modify_generational_global_root(value *r, value newval); +#ifdef __cplusplus +} +#endif + #endif /* CAML_MEMORY_H */ diff --git a/byterun/meta.c b/byterun/meta.c index 1ed4fbdd..a547b991 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -15,6 +15,7 @@ /* Primitives for the toplevel */ +#include #include "alloc.h" #include "config.h" #include "fail.h" @@ -61,6 +62,17 @@ CAMLprim value caml_reify_bytecode(value prog, value len) return clos; } +CAMLprim value caml_register_code_fragment(value prog, value len, value digest) +{ + struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); + cf->code_start = (char *) prog; + cf->code_end = (char *) prog + Long_val(len); + memcpy(cf->digest, String_val(digest), 16); + cf->digest_computed = 1; + caml_ext_table_add(&caml_code_fragments_table, cf); + return Val_unit; +} + CAMLprim value caml_realloc_global(value size) { mlsize_t requested_size, actual_size, i; diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 91aa2979..8b8b8ff0 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ @@ -160,9 +160,14 @@ void caml_oldify_one (value v, value *p) Assert (tag == Forward_tag); if (Is_block (f)){ - vv = Is_in_value_area(f); - if (vv) { + if (Is_young (f)){ + vv = 1; ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + }else{ + vv = Is_in_value_area(f); + if (vv){ + ft = Tag_val (f); + } } } if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index 8e834129..82c82cd3 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/misc.c b/byterun/misc.c index e8597ee3..927cbd81 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/misc.h b/byterun/misc.h index d0aaffd1..e970d3d0 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index d76c1f1d..d560d1b3 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ @@ -22,6 +22,10 @@ #include "config.h" #include "misc.h" +#ifdef __cplusplus +extern "C" { +#endif + /* Definitions word: Four bytes on 32 and 16 bit architectures, @@ -245,6 +249,9 @@ CAMLextern void caml_Store_double_val (value,double); double caml__temp_d = (d); \ Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ }while(0) +CAMLextern mlsize_t caml_array_length (value); /* size in items */ +CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ + /* Custom blocks. They contain a pointer to a "method suite" of functions (for finalization, comparison, hashing, etc) @@ -291,5 +298,9 @@ CAMLextern header_t caml_atom_table[]; extern value caml_global_data; +#ifdef __cplusplus +} +#endif + #endif /* CAML_MLVALUES_H */ diff --git a/byterun/obj.c b/byterun/obj.c index e085d672..7d09105b 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -171,7 +171,7 @@ CAMLprim value caml_obj_add_offset (value v, value offset) } /* The following functions are used in stdlib/lazy.ml. - They are not written in O'Caml because they must be atomic with respect + They are not written in OCaml because they must be atomic with respect to the GC. */ @@ -191,7 +191,7 @@ CAMLprim value caml_lazy_make_forward (value v) CAMLlocal1 (res); res = caml_alloc_small (1, Forward_tag); - Modify (&Field (res, 0), v); + Field (res, 0) = v; CAMLreturn (res); } diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 248b3f6a..902ea2de 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/parsing.c b/byterun/parsing.c index bcb9e5fa..3d5ea833 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -125,7 +125,7 @@ static void print_token(struct parser_tables *tables, int state, value tok) state, token_name(tables->names_block, Tag_val(tok))); v = Field(tok, 0); if (Is_long(v)) - fprintf(stderr, "%ld", Long_val(v)); + fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); else if (Tag_val(v) == String_tag) fprintf(stderr, "%s", String_val(v)); else if (Tag_val(v) == Double_tag) diff --git a/byterun/prims.h b/byterun/prims.h index d8c1671e..3d7bb6d8 100644 --- a/byterun/prims.h +++ b/byterun/prims.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/printexc.c b/byterun/printexc.c index f72157ff..e891d9c6 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -60,7 +60,8 @@ CAMLexport char * caml_format_exception(value exn) /* Check for exceptions in the style of Match_failure and Assert_failure */ if (Wosize_val(exn) == 2 && Is_block(Field(exn, 1)) && - Tag_val(Field(exn, 1)) == 0) { + Tag_val(Field(exn, 1)) == 0 && + caml_is_special_exception(Field(exn, 0))) { bucket = Field(exn, 1); start = 0; } else { @@ -72,7 +73,7 @@ CAMLexport char * caml_format_exception(value exn) if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { - sprintf(intbuf, "%ld", Long_val(v)); + sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); diff --git a/byterun/printexc.h b/byterun/printexc.h index e7d17688..4624086c 100644 --- a/byterun/printexc.h +++ b/byterun/printexc.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -20,8 +20,16 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + + CAMLextern char * caml_format_exception (value); void caml_fatal_uncaught_exception (value) Noreturn; +#ifdef __cplusplus +} +#endif #endif /* CAML_PRINTEXC_H */ diff --git a/byterun/reverse.h b/byterun/reverse.h index e80d1f7d..a48b6f25 100644 --- a/byterun/reverse.h +++ b/byterun/reverse.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/roots.c b/byterun/roots.c index 74fbb41e..8a4d23b3 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/roots.h b/byterun/roots.h index 95c2f63f..f2d3bd69 100644 --- a/byterun/roots.h +++ b/byterun/roots.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/signals.c b/byterun/signals.c index 90fe8919..40ba0ab5 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/signals.h b/byterun/signals.h index e5ba9877..fb03b30d 100644 --- a/byterun/signals.h +++ b/byterun/signals.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ @@ -22,6 +22,10 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + /* */ CAMLextern intnat volatile caml_signals_are_pending; CAMLextern intnat volatile caml_pending_signals[]; @@ -48,4 +52,8 @@ CAMLextern int (*caml_try_leave_blocking_section_hook)(void); CAMLextern void (* volatile caml_async_action_hook)(void); /* */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_SIGNALS_H */ diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c index 52381493..f52ee5a4 100644 --- a/byterun/signals_byt.c +++ b/byterun/signals_byt.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/signals_machdep.h b/byterun/signals_machdep.h index 08c5f4cb..0308d3c1 100644 --- a/byterun/signals_machdep.h +++ b/byterun/signals_machdep.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ diff --git a/byterun/stacks.c b/byterun/stacks.c index ed06f953..5f7a871d 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/stacks.h b/byterun/stacks.h index 48e8acc9..f8469572 100644 --- a/byterun/stacks.h +++ b/byterun/stacks.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/startup.c b/byterun/startup.c index 20e61e7d..feb5029a 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ @@ -216,7 +216,7 @@ static char * read_section(int fd, struct exec_trailer *trail, char *name) Algorithm: 1- If argument 0 is a valid byte-code file that does not start with #!, then we are in case 3 and we pass the same command line to the - Objective Caml program. + OCaml program. 2- In all other cases, we parse the command line as: (whatever) [options] bytecode args... and we strip "(whatever) [options]" from the command line. @@ -247,7 +247,7 @@ static int parse_command_line(char **argv) #endif case 'v': if (!strcmp (argv[i], "-version")){ - printf ("The Objective Caml runtime, version " OCAML_VERSION "\n"); + printf ("The OCaml runtime, version " OCAML_VERSION "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ printf (OCAML_VERSION "\n"); @@ -370,12 +370,12 @@ CAMLexport void caml_main(char **argv) fd = caml_attempt_open(&exe_name, &trail, 1); switch(fd) { case FILE_NOT_FOUND: - caml_fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]); + caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]); break; case BAD_BYTECODE: caml_fatal_error_arg( - "Fatal error: the file %s is not a bytecode executable file\n", - argv[pos]); + "Fatal error: the file '%s' is not a bytecode executable file\n", + exe_name); break; } } diff --git a/byterun/startup.h b/byterun/startup.h index 0d1a5a60..5a42a73a 100644 --- a/byterun/startup.h +++ b/byterun/startup.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/str.c b/byterun/str.c index 760b154e..3941cae1 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/sys.c b/byterun/sys.c index 9928910f..ce364d8c 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -51,10 +51,6 @@ #include "stacks.h" #include "sys.h" -#ifndef _WIN32 -extern int errno; -#endif - static char * error_message(void) { return strerror(errno); @@ -295,27 +291,49 @@ CAMLprim value caml_sys_time(value unit) } #ifdef _WIN32 -extern intnat caml_win32_random_seed (void); +extern int caml_win32_random_seed (intnat data[16]); #endif CAMLprim value caml_sys_random_seed (value unit) { + intnat data[16]; + int n, i; + value res; #ifdef _WIN32 - return Val_long(caml_win32_random_seed()); + n = caml_win32_random_seed(data); #else - intnat seed; + int fd; + n = 0; + /* Try /dev/urandom first */ + fd = open("/dev/urandom", O_RDONLY, 0); + if (fd != -1) { + unsigned char buffer[12]; + int nread = read(fd, buffer, 12); + close(fd); + while (nread > 0) data[n++] = buffer[--nread]; + } + /* If the read from /dev/urandom fully succeeded, we now have 96 bits + of good random data and can stop here. Otherwise, complement + whatever we got (probably nothing) with some not-very-random data. */ + if (n < 12) { #ifdef HAS_GETTIMEOFDAY - struct timeval tv; - gettimeofday(&tv, NULL); - seed = tv.tv_sec ^ tv.tv_usec; + struct timeval tv; + gettimeofday(&tv, NULL); + data[n++] = tv.tv_usec; + data[n++] = tv.tv_sec; #else - seed = time (NULL); + data[n++] = time(NULL); #endif #ifdef HAS_UNISTD - seed ^= (getppid() << 16) ^ getpid(); + data[n++] = getpid(); + data[n++] = getppid(); #endif - return Val_long(seed); + } #endif + /* Convert to an OCaml array of ints */ + res = caml_alloc_small(n, 0); + for (i = 0; i < n; i++) Field(res, i) = Val_long(data[i]); + return res; } CAMLprim value caml_sys_get_config(value unit) @@ -324,9 +342,14 @@ CAMLprim value caml_sys_get_config(value unit) CAMLlocal2 (result, ostype); ostype = caml_copy_string(OCAML_OS_TYPE); - result = caml_alloc_small (2, 0); + result = caml_alloc_small (3, 0); Field(result, 0) = ostype; Field(result, 1) = Val_long (8 * sizeof(value)); +#ifdef ARCH_BIG_ENDIAN + Field(result, 2) = Val_true; +#else + Field(result, 2) = Val_false; +#endif CAMLreturn (result); } diff --git a/byterun/sys.h b/byterun/sys.h index 4ad8011d..c6f5d320 100644 --- a/byterun/sys.h +++ b/byterun/sys.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/terminfo.c b/byterun/terminfo.c index e4502fb0..67975696 100644 --- a/byterun/terminfo.c +++ b/byterun/terminfo.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/ui.h b/byterun/ui.h index fcd9cd9f..0c3309b3 100644 --- a/byterun/ui.h +++ b/byterun/ui.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/unix.c b/byterun/unix.c index cdc1f2a0..664c32b1 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/byterun/weak.c b/byterun/weak.c index c6c4a223..efdb15e9 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/weak.h b/byterun/weak.h index 270082db..a30001a7 100644 --- a/byterun/weak.h +++ b/byterun/weak.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ diff --git a/byterun/win32.c b/byterun/win32.c index 866977b1..4cc38415 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -528,18 +528,15 @@ void caml_win32_overflow_detection() /* Seeding of pseudo-random number generators */ -intnat caml_win32_random_seed (void) +int caml_win32_random_seed (intnat data[16]) { - intnat seed; - SYSTEMTIME t; - - GetLocalTime(&t); - seed = t.wMonth; - seed = (seed << 5) ^ t.wDay; - seed = (seed << 4) ^ t.wHour; - seed = (seed << 5) ^ t.wMinute; - seed = (seed << 5) ^ t.wSecond; - seed = (seed << 9) ^ t.wMilliseconds; - seed ^= GetCurrentProcessId(); - return seed; + /* For better randomness, consider: + http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp + */ + FILETIME t; + GetSystemTimeAsFileTime(&t); + data[0] = t.dwLowDateTime; + data[1] = t.dwHighDateTime; + data[2] = GetCurrentProcessId(); + return 3; } diff --git a/camlp4/.cvsignore b/camlp4/.cvsignore deleted file mode 100644 index 493096e2..00000000 --- a/camlp4/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm* -.cache-status -*.tmp.ml diff --git a/camlp4/.ignore b/camlp4/.ignore new file mode 100644 index 00000000..481c691a --- /dev/null +++ b/camlp4/.ignore @@ -0,0 +1,2 @@ +.cache-status +*.tmp.ml diff --git a/camlp4/CHANGES b/camlp4/CHANGES index ef48fc42..0251cd16 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -497,7 +497,7 @@ Camlp4 Version 3.00: - [Apr 17, 00] Added support for labels and variants. - [Mar 28, 00] Improved the grammars: now the rules starting with n terminals are locally LL(n), i.e. if any of the terminal fails, it is - not Error but just Failure. Allows to write the Ocaml syntax case: + not Error but just Failure. Allows to write the OCaml syntax case: ( operator ) ( expr ) with the problem of "( - )" as: @@ -518,7 +518,7 @@ Camlp4 Version 2.04: - [Nov 23, 99] Changed the module name Config into Oconfig, because of conflict problem when applications want to link with the module Config of - Ocaml. + OCaml. Camlp4 Version 2.03: -------------------- @@ -534,9 +534,9 @@ Camlp4 Version 2.03: - [Mar 9, 99] Added missing case in pr_depend.ml. * Other: - - [Sep 10, 99] Updated from current Ocaml new interfaces. + - [Sep 10, 99] Updated from current OCaml new interfaces. - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same - change in Ocaml. + change in OCaml. - [Jun 24, 99] Added missing "constraint" construction in types - [Jun 15, 99] Added option -I for command "mkcamlp4". - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp @@ -555,11 +555,11 @@ Camlp4 Version 2.02: -------------------- * Parsing: - - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect Ocaml parsing of the + - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect OCaml parsing of the program example: "type t = F(B).t" - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()". - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo". - - [Dec 22, 98] Fixed precedence of "!=" in Ocaml syntax + - [Dec 22, 98] Fixed precedence of "!=" in OCaml syntax * Printing: - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies. @@ -603,7 +603,7 @@ Grammar interface Missing features added * Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo) * Added print "assert" statement (pr_o.cmo, pr_r.cmo) -* Added parsing of infix operators like in Ocaml (e.g. |||) in pa_o.cmo +* Added parsing of infix operators like in OCaml (e.g. |||) in pa_o.cmo Compilation * Added "make scratch" @@ -636,20 +636,20 @@ Camlp4 Version 2.00: -------------------- * Designation "righteous" has been renamed "revised". -* Added class and objects in Ocaml printing (pr_o.cmo), revised parsing +* Added class and objects in OCaml printing (pr_o.cmo), revised parsing (pa_r.cmo) and printing (pr_r.cmo). -* Fixed bug in Ocaml syntax: let _, x = 1, 2;; was refused. +* Fixed bug in OCaml syntax: let _, x = 1, 2;; was refused. Camlp4 Version 2.00--1: ----------------------- -* Added classes and objects in Ocaml syntax (pa_o.cmo) +* Added classes and objects in OCaml syntax (pa_o.cmo) * Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o Camlp4 Version 2.00--: ---------------------- -* Adapted for Ocaml 2.00. +* Adapted for OCaml 2.00. * No objects and classes in this version. * Added "let module" parsing and printing. @@ -672,7 +672,7 @@ Camlp4 Version 2.00--: * Added missing statement "include" in signature item in normal and righteous syntaxes * Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o): - now before "or", like in Ocaml compiler. + now before "or", like in OCaml compiler. * Same change in righteous syntax, by symmetry. Camlp4 Version 1.07.2: @@ -684,8 +684,8 @@ Errors and missings in normal and righteous syntaxes. * Added missing syntax (normal): type foo = bar = {......} * Added missing syntax (normal): did not accept separators before ending constructions (many of them). -* Fixed bug: "assert false" is now of type 'a, like in Ocaml. -* Fixed to match Ocaml feature: "\^" is "\^" in Ocaml, but just "^" in Camlp4. +* Fixed bug: "assert false" is now of type 'a, like in OCaml. +* Fixed to match OCaml feature: "\^" is "\^" in OCaml, but just "^" in Camlp4. * Fixed bug in Windows NT/95: problem in backslash before newlines in strings Grammars, EXTEND, DELETE_RULE @@ -736,7 +736,7 @@ Camlp4 Version 1.07.1: * Environment variable CAMLP4LIB to change camlp4 library directory * Grammar: empty rules have a correct location instead of (-1, -1) * Compilation possible in Windows NT/95 -* String constants no more shared while parsing Ocaml +* String constants no more shared while parsing OCaml * Fixed bug in antiquotations in q_MLast.cmo (bad errors locations) * Fixed bug in antiquotations in q_MLast.cmo (EOI not checked) * Fixed bug in Plexer: could not create keywords with iso 8859 characters @@ -748,17 +748,17 @@ Camlp4 Version 1.07: * Added iso 8859 uppercase characters for uidents in plexer.ml * Fixed bug factorization IDENT in grammars * Fixed bug pr_o.cmo was printing "declare" -* Fixed bug constructor arity in Ocaml syntax (pa_o.cmo). +* Fixed bug constructor arity in OCaml syntax (pa_o.cmo). * Changed "lazy" into "slazy". * Completed pa_ifdef.cmo. Camlp4 Version 1.06: -------------------- -* Adapted to Ocaml 1.06. -* Changed version number to match Ocaml's => 1.06 too. -* Deleted module Gstream, using Ocaml's Stream. -* Generate different AST for C(x,y) and C x y (change done in Ocaml's compiler) +* Adapted to OCaml 1.06. +* Changed version number to match OCaml's => 1.06 too. +* Deleted module Gstream, using OCaml's Stream. +* Generate different AST for C(x,y) and C x y (change done in OCaml's compiler) * No more message "Interrupted" in toplevel in case of syntax error. * Added flag to suppress warnings while extending grammars. * Completed some missing statements and declarations (objects) @@ -832,7 +832,7 @@ Camlp4 Version 0.6: when the quotation is in a context of a pattern. These expanders, returning strings which are parsed afterwards, may work for some language syntax and/or language extensions used (e.g. may work for - Righteous syntax and not for Ocaml syntax). + Righteous syntax and not for OCaml syntax). - A new type of expander returning directly syntax trees. A pair of functions, for expressions and for patterns must be provided. These expanders are independant from the language syntax and/or @@ -842,12 +842,12 @@ Camlp4 Version 0.6: been deleted; one can use "ctyp", "patt", and "expr" in position of pattern or expression. ---- Ocaml and Righteous syntaxes +--- OCaml and Righteous syntaxes * Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo" -* Corrected behavior different from Ocaml's: "^" and "@" were at the same - level than "=": now, like Ocaml, they have a separated right associative +* Corrected behavior different from OCaml's: "^" and "@" were at the same + level than "=": now, like OCaml, they have a separated right associative level. --- Grammars behavior @@ -881,7 +881,7 @@ Camlp4 Version 0.5: * Possible creation of native code library (make opt) -* Ocaml and Righteous Syntax more complete +* OCaml and Righteous Syntax more complete * Added pa_ru.cmo for compiling sequences of type unit (Righteous) diff --git a/camlp4/Camlp4/.cvsignore b/camlp4/Camlp4/.cvsignore deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml index 8f62adf3..22874373 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -1,3 +1,20 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Note: when you modify these types you must increment + ast magic numbers defined in Camlp4_config.ml. *) + type loc = Loc.t and meta_bool = [ BTrue @@ -61,9 +78,12 @@ | TyObj of loc and ctyp and row_var_flag | TyOlb of loc and string and ctyp (* ?s:t *) | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) + | TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *) | TyQuo of loc and string (* 's *) | TyQuP of loc and string (* +'s *) | TyQuM of loc and string (* -'s *) + | TyAnP of loc (* +_ *) + | TyAnM of loc (* -_ *) | TyVrn of loc and string (* `s *) | TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) | TyCol of loc and ctyp and ctyp (* t : t *) @@ -116,7 +136,8 @@ | PaTyc of loc and patt and ctyp (* (p : t) *) | PaTyp of loc and ident (* #i *) | PaVrn of loc and string (* `s *) - | PaLaz of loc and patt (* lazy p *) ] + | PaLaz of loc and patt (* lazy p *) + | PaMod of loc and string (* (module M) *) ] and expr = [ ExNil of loc | ExId of loc and ident (* i *) diff --git a/camlp4/Camlp4/Debug.ml b/camlp4/Camlp4/Debug.ml index cbd30922..73a38db8 100644 --- a/camlp4/Camlp4/Debug.ml +++ b/camlp4/Camlp4/Debug.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -50,24 +50,15 @@ value mode = value formatter = let header = "camlp4-debug: " in - let normal s = - let rec self from accu = - try - let i = String.index_from s from '\n' - in self (i + 1) [String.sub s from (i - from + 1) :: accu] - with - [ Not_found -> [ String.sub s from (String.length s - from) :: accu ] ] - in String.concat header (List.rev (self 0 [])) in - let after_new_line str = header ^ normal str in - let f = ref after_new_line in - let output str chr = do { - output_string out_channel (f.val str); - output_char out_channel chr; - f.val := if chr = '\n' then after_new_line else normal; - } in + let at_bol = ref True in (make_formatter (fun buf pos len -> - let p = pred len in output (String.sub buf pos p) buf.[pos + p]) + for i = pos to pos + len - 1 do + if at_bol.val then output_string out_channel header else (); + let ch = buf.[i]; + output_char out_channel ch; + at_bol.val := ch = '\n'; + done) (fun () -> flush out_channel)); value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section; diff --git a/camlp4/Camlp4/Debug.mli b/camlp4/Camlp4/Debug.mli index 13af7733..97597f9c 100644 --- a/camlp4/Camlp4/Debug.mli +++ b/camlp4/Camlp4/Debug.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/ErrorHandler.ml b/camlp4/Camlp4/ErrorHandler.ml index 231efed9..bfefa49a 100644 --- a/camlp4/Camlp4/ErrorHandler.ml +++ b/camlp4/Camlp4/ErrorHandler.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -92,7 +92,7 @@ module ObjTools = struct | x when x = Obj.string_tag -> "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" | x when x = Obj.double_tag -> - string_of_float (Obj.magic r : float) + Camlp4_import.Oprint.float_repres (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> diff --git a/camlp4/Camlp4/ErrorHandler.mli b/camlp4/Camlp4/ErrorHandler.mli index 67481145..d73238df 100644 --- a/camlp4/Camlp4/ErrorHandler.mli +++ b/camlp4/Camlp4/ErrorHandler.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/OCamlInitSyntax.ml b/camlp4/Camlp4/OCamlInitSyntax.ml index 85f8915f..c424bfa7 100644 --- a/camlp4/Camlp4/OCamlInitSyntax.ml +++ b/camlp4/Camlp4/OCamlInitSyntax.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Options.ml b/camlp4/Camlp4/Options.ml index e9979bee..20503b40 100644 --- a/camlp4/Camlp4/Options.ml +++ b/camlp4/Camlp4/Options.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Options.mli b/camlp4/Camlp4/Options.mli index caffd8c2..2deb878d 100644 --- a/camlp4/Camlp4/Options.mli +++ b/camlp4/Camlp4/Options.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/PreCast.ml b/camlp4/Camlp4/PreCast.ml index 8e3da348..16974851 100644 --- a/camlp4/Camlp4/PreCast.ml +++ b/camlp4/Camlp4/PreCast.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/PreCast.mli b/camlp4/Camlp4/PreCast.mli index 1c6eb2e9..a7dad534 100644 --- a/camlp4/Camlp4/PreCast.mli +++ b/camlp4/Camlp4/PreCast.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml index bd220c16..5b34e994 100644 --- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli index d35642ab..5a0eb96f 100644 --- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml index dd6c60f6..57d2a15e 100644 --- a/camlp4/Camlp4/Printers/DumpOCamlAst.ml +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.mli b/camlp4/Camlp4/Printers/DumpOCamlAst.mli index 3233557d..16eafbdb 100644 --- a/camlp4/Camlp4/Printers/DumpOCamlAst.mli +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/Null.ml b/camlp4/Camlp4/Printers/Null.ml index a9a2c486..3b3b9549 100644 --- a/camlp4/Camlp4/Printers/Null.ml +++ b/camlp4/Camlp4/Printers/Null.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/Null.mli b/camlp4/Camlp4/Printers/Null.mli index d7715117..f81ce613 100644 --- a/camlp4/Camlp4/Printers/Null.mli +++ b/camlp4/Camlp4/Printers/Null.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index 06765691..def7f196 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -106,10 +106,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" str (Lexer.Error.to_string exn)) ]; - value ocaml_char = - fun - [ "'" -> "\\'" - | c -> c ]; + value ocaml_char x = x; value rec get_expr_args a al = match a with @@ -371,7 +368,12 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct match Ast.list_of_ctyp t [] with [ [] -> () | ts -> - pp f "@[| %a@]" (list o#ctyp "@ | ") ts ]; + pp f "@[| %a@]" (list o#constructor_declaration "@ | ") ts ]; + + method private constructor_declaration f t = + match t with + [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3 + | t -> o#ctyp f t ]; method string f = pp f "%s"; method quoted_string f = pp f "%S"; @@ -554,7 +556,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< $int64:s$ >> -> o#numeric f s "L" | <:expr< $int32:s$ >> -> o#numeric f s "l" | <:expr< $flo:s$ >> -> o#numeric f s "" - | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) + | <:expr< $chr:s$ >> -> pp f "'%s'" s | <:expr< $id:i$ >> -> o#var_ident f i | <:expr< { $b$ } >> -> pp f "@[@[{%a@]@ }@]" o#record_binding b @@ -654,6 +656,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:patt< $id:i$ >> -> o#var_ident f i | <:patt< $anti:s$ >> -> o#anti f s | <:patt< _ >> -> pp f "_" + | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p | <:patt< { $p$ } >> -> pp f "@[{@ %a@]@ }" o#patt p | <:patt< $str:s$ >> -> pp f "\"%s\"" s @@ -663,7 +666,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:patt< $int32:s$ >> -> o#numeric f s "l" | <:patt< $int:s$ >> -> o#numeric f s "" | <:patt< $flo:s$ >> -> o#numeric f s "" - | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) + | <:patt< $chr:s$ >> -> pp f "'%s'" s | <:patt< ~ $s$ >> -> pp f "~%s" s | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i @@ -695,6 +698,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ <:ctyp< $id:i$ >> -> o#ident f i | <:ctyp< $anti:s$ >> -> o#anti f s | <:ctyp< _ >> -> pp f "_" + | Ast.TyAnP _ -> pp f "+_" + | Ast.TyAnM _ -> pp f "-_" | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t | <:ctyp< < > >> -> pp f "< >" @@ -758,6 +763,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:ctyp< ! $t1$ . $t2$ >> -> let (a, al) = get_ctyp_args t1 [] in pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 + | Ast.TyTypePol (_,t1,t2) -> + let (a, al) = get_ctyp_args t1 [] in + pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t | t -> o#simple_ctyp f t ]; @@ -878,7 +886,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let () = o#node f mt Ast.loc_of_module_type in match mt with [ <:module_type<>> -> assert False - | <:module_type< module type of $me$ >> -> pp f "@[<2>module type of@ %a@]" o#module_expr me + | <:module_type< module type of $me$ >> -> + pp f "@[<2>module type of@ %a@]" o#module_expr me | <:module_type< $id:i$ >> -> o#ident f i | <:module_type< $anti:s$ >> -> o#anti f s | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> @@ -939,7 +948,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let () = o#node f ce Ast.loc_of_class_expr in match ce with [ <:class_expr< $ce$ $e$ >> -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#expr e + pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e | <:class_expr< $id:i$ >> -> pp f "@[<2>%a@]" o#ident i | <:class_expr< $id:i$ [ $t$ ] >> -> diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli index 1ec7120b..0d36742b 100644 --- a/camlp4/Camlp4/Printers/OCaml.mli +++ b/camlp4/Camlp4/Printers/OCaml.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml index 19945879..b91f8ea7 100644 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Printers/OCamlr.mli b/camlp4/Camlp4/Printers/OCamlr.mli index f1db176a..45fcbdef 100644 --- a/camlp4/Camlp4/Printers/OCamlr.mli +++ b/camlp4/Camlp4/Printers/OCamlr.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml index e286eafb..010a8310 100644 --- a/camlp4/Camlp4/Register.ml +++ b/camlp4/Camlp4/Register.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Register.mli b/camlp4/Camlp4/Register.mli index bd8e13a1..d997d417 100644 --- a/camlp4/Camlp4/Register.mli +++ b/camlp4/Camlp4/Register.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml index 1664be75..bae3da5a 100644 --- a/camlp4/Camlp4/Sig.ml +++ b/camlp4/Camlp4/Sig.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -64,6 +64,16 @@ end; (** A signature for locations. *) module type Loc = sig + (** The type of locations. Note that, as for OCaml locations, + character numbers in locations refer to character numbers in the + parsed character stream, while line numbers refer to line + numbers in the source file. The source file and the parsed + character stream differ, for instance, when the parsed character + stream contains a line number directive. The line number + directive will only update the file-name field and the + line-number field of the position. It makes therefore no sense + to use character numbers with the source file if the sources + contain line number directives. *) type t; (** Return a start location for the given file name. @@ -96,7 +106,8 @@ module type Loc = sig stop_line, stop_bol, stop_off, ghost)]. *) value to_tuple : t -> (string * int * int * int * int * int * int * bool); - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *) + (** [merge loc1 loc2] Return a location that starts at [loc1] and end at + [loc2]. *) value merge : t -> t -> t; (** The stop pos becomes equal to the start pos. *) @@ -128,19 +139,19 @@ module type Loc = sig (** Return the line number of the ending of this location. *) value stop_line : t -> int; - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream to the begining of the line of location's begining. *) value start_bol : t -> int; - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream to the begining of the line of location's ending. *) value stop_bol : t -> int; - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream of the begining of this location. *) value start_off : t -> int; - (** Return the number of characters from the begining of the file + (** Return the number of characters from the begining of the stream of the ending of this location. *) value stop_off : t -> int; @@ -843,7 +854,7 @@ module type Token = sig module Error : Error; end; -(** This signature describes tokens for the Objective Caml and the Revised +(** This signature describes tokens for the OCaml and the Revised syntax lexing rules. For some tokens the data constructor holds two representations with the evaluated one and the source one. For example the INT data constructor holds an integer and a string, this string can diff --git a/camlp4/Camlp4/Struct/.cvsignore b/camlp4/Camlp4/Struct/.cvsignore deleted file mode 100644 index 262784db..00000000 --- a/camlp4/Camlp4/Struct/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -Lexer.ml -Camlp4Ast.tmp.ml diff --git a/camlp4/Camlp4/Struct/.ignore b/camlp4/Camlp4/Struct/.ignore new file mode 100644 index 00000000..262784db --- /dev/null +++ b/camlp4/Camlp4/Struct/.ignore @@ -0,0 +1,2 @@ +Lexer.ml +Camlp4Ast.tmp.ml diff --git a/camlp4/Camlp4/Struct/AstFilters.ml b/camlp4/Camlp4/Struct/AstFilters.ml index 665e610a..6474ba8e 100644 --- a/camlp4/Camlp4/Struct/AstFilters.ml +++ b/camlp4/Camlp4/Struct/AstFilters.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast index 6c4ea3bc..9c5a9975 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast.mlast +++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -123,6 +123,7 @@ module Make (Loc : Sig.Loc) | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p | <:patt< lazy $p$ >> -> is_irrefut_patt p | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) + | <:patt< (module $_$) >> -> True | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 92c64eb8..e73e875f 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -133,7 +133,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct let rec self i acc = match i with - [ <:ident< $i1$.$i2$ >> -> + [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> -> + (ldot (lident "*predef*") "option", `lident) + | <:ident< $i1$.$i2$ >> -> self i2 (Some (self i1 acc)) | <:ident< $i1$ $i2$ >> -> let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in @@ -204,6 +206,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:ctyp< '$s$ >> -> [s] | _ -> assert False ]; + value predef_option loc = + TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option"))); + value rec ctyp = fun [ TyId loc i -> @@ -226,7 +231,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | TyArr loc (TyLab _ lab t1) t2 -> mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in + let t1 = TyApp loc1 (predef_option loc1) t1 in mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) @@ -261,6 +266,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | TyAnt loc _ -> error loc "antiquotation not allowed here" | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | + TyAnP _ | TyAnM _ | TyTypePol _ _ _ | TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ -> assert False ] and row_field = fun @@ -285,8 +291,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct and package_type_constraints wc acc = match wc with [ <:with_constr<>> -> acc - | <:with_constr< type $lid:id$ = $ct$ >> -> - [(id, ctyp ct) :: acc] + | <:with_constr< type $id:id$ = $ct$ >> -> + [(ident id, ctyp ct) :: acc] | <:with_constr< $wc1$ and $wc2$ >> -> package_type_constraints wc1 (package_type_constraints wc2 acc) | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ] @@ -319,9 +325,14 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False (*FIXME*) ]; value mkvariant = fun - [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc) + [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc) | <:ctyp@loc< $uid:s$ of $t$ >> -> - (conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc) + (conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc) + | <:ctyp@loc< $uid:s$ : ($t$ -> $u$) >> -> + (conv_con s, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc) + | <:ctyp@loc< $uid:s$ : $t$ >> -> + (conv_con s, [], Some (ctyp t), mkloc loc) + | _ -> assert False (*FIXME*) ]; value rec type_decl tl cl loc m pflag = fun @@ -346,7 +357,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] ; - value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t; + value type_decl tl cl t loc = type_decl tl cl loc None False t; value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; @@ -381,6 +392,17 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] | _ -> assert False ]; + value rec optional_type_parameters t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc) + | <:ctyp< +'$s$ >> -> [(Some s, (True, False)) :: acc] + | Ast.TyAnP _loc -> [(None, (True, False)) :: acc] + | <:ctyp< -'$s$ >> -> [(Some s, (False, True)) :: acc] + | Ast.TyAnM _loc -> [(None, (False, True)) :: acc] + | <:ctyp< '$s$ >> -> [(Some s, (False, False)) :: acc] + | Ast.TyAny _loc -> [(None, (False, False)) :: acc] + | _ -> assert False ]; + value rec class_parameters t acc = match t with [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) @@ -393,7 +415,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct match t with [ <:ctyp< $t1$ $t2$ >> -> type_parameters_and_type_name t1 - (type_parameters t2 acc) + (optional_type_parameters t2 acc) | <:ctyp< $id:i$ >> -> (ident i, acc) | _ -> assert False ]; @@ -536,8 +558,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn loc s -> mkpat loc (Ppat_variant s None) + | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None) | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) + | PaMod loc m -> mkpat loc (Ppat_unpack m) | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> error (loc_of_patt p) "invalid pattern" ] and mklabpat = @@ -589,6 +612,55 @@ module Make (Ast : Sig.Camlp4Ast) = struct [ <:ctyp<>> -> acc | t -> list_of_ctyp t acc ]; +value varify_constructors var_names = + let rec loop t = + let desc = + match t.ptyp_desc with + [ + Ptyp_any -> Ptyp_any + | Ptyp_var x -> Ptyp_var x + | Ptyp_arrow label core_type core_type' -> + Ptyp_arrow label (loop core_type) (loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr (Lident s) [] when List.mem s var_names -> + Ptyp_var ("&" ^ s) + | Ptyp_constr longident lst -> + Ptyp_constr longident (List.map loop lst) + | Ptyp_object lst -> + Ptyp_object (List.map loop_core_field lst) + | Ptyp_class longident lst lbl_list -> + Ptyp_class (longident, List.map loop lst, lbl_list) + | Ptyp_alias core_type string -> + Ptyp_alias(loop core_type, string) + | Ptyp_variant row_field_list flag lbl_lst_option -> + Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly string_lst core_type -> + Ptyp_poly(string_lst, loop core_type) + | Ptyp_package longident lst -> + Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) +] + in + {(t) with ptyp_desc = desc} + and loop_core_field t = + let desc = + match t.pfield_desc with + [ Pfield(n,typ) -> + Pfield(n,loop typ) + | Pfield_var -> + Pfield_var] + in + { (t) with pfield_desc=desc} + and loop_row_field x = + match x with + [ Rtag(label,flag,lst) -> + Rtag(label,flag,List.map loop lst) + | Rinherit t -> + Rinherit (loop t) ] + in + loop; + + + value rec expr = fun [ <:expr@loc< $x$.val >> -> @@ -769,16 +841,17 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:expr@loc< $uid:s$ >> -> (* let ca = constructors_arity () in *) mkexp loc (Pexp_construct (lident (conv_con s)) None True) - | ExVrn loc s -> mkexp loc (Pexp_variant s None) + | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) | ExWhi loc e1 el -> 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)) | <:expr@loc< (module $me$ : $pt$) >> -> - mkexp loc (Pexp_pack (module_expr me) (package_type pt)) - | <:expr@loc< (module $_$) >> -> - error loc "(module_expr : package_type) expected here" + mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), + Some (mktyp loc (Ptyp_package (package_type pt))), None)) + | <:expr@loc< (module $me$) >> -> + mkexp loc (Pexp_pack (module_expr me)) | ExFUN loc i e -> mkexp loc (Pexp_newtype i (expr e)) | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" @@ -802,6 +875,32 @@ module Make (Ast : Sig.Camlp4Ast) = struct match x with [ <:binding< $x$ and $y$ >> -> binding x (binding y acc) + | <:binding@_loc< $lid:bind_name$ = ($e$ : $TyTypePol _ vs ty$) >> -> + (* this code is not pretty because it is temporary *) + let rec id_to_string x = + match x with + [ <:ctyp< $lid:x$ >> -> [x] + | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y) + | _ -> assert False] + in + let vars = id_to_string vs in + let ampersand_vars = List.map (fun x -> "&" ^ x) vars in + let ty' = varify_constructors vars (ctyp ty) in + let mkexp = mkexp _loc in + let mkpat = mkpat _loc in + let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in + let rec mk_newtypes x = + match x with + [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) + | [newtype :: newtypes] -> + mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) + | [] -> assert False] + in + let pat = + mkpat (Ppat_constraint (mkpat (Ppat_var bind_name), mktyp _loc (Ptyp_poly ampersand_vars ty'))) + in + let e = mk_newtypes vars in + [( pat, e) :: acc] | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> -> [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc] | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc] @@ -835,7 +934,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct match x with [ <:ctyp< $x$ and $y$ >> -> mktype_decl x (mktype_decl y acc) - | Ast.TyDcl _ c tl td cl -> + | Ast.TyDcl loc c tl td cl -> let cl = List.map (fun (t1, t2) -> @@ -843,7 +942,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct (ctyp t1, ctyp t2, mkloc loc)) cl in - [(c, type_decl (List.fold_right type_parameters tl []) cl td) :: acc] + [(c, type_decl (List.fold_right optional_type_parameters tl []) cl td loc) :: acc] | _ -> assert False ] and module_type = fun @@ -920,9 +1019,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:module_expr@loc< ($me$ : $mt$) >> -> mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) | <:module_expr@loc< (value $e$ : $pt$) >> -> - mkmod loc (Pmod_unpack (expr e) (package_type pt)) - | <:module_expr@loc< (value $_$) >> -> - error loc "(value expr) not supported yet" + mkmod loc (Pmod_unpack ( + mkexp loc (Pexp_constraint (expr e, + Some (mktyp loc (Ptyp_package (package_type pt))), + None)))) + | <:module_expr@loc< (value $e$) >> -> + mkmod loc (Pmod_unpack (expr e)) | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ] and str_item s l = match s with @@ -942,6 +1044,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct (List.map ctyp (list_of_ctyp t []))) :: l ] | <:str_item@loc< exception $uid:s$ = $i$ >> -> [mkstr loc (Pstr_exn_rebind (conv_con s) (ident i)) :: l ] + | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> -> + error loc "type in exception alias" | StExc _ _ _ -> assert False (*FIXME*) | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] | StExt loc n t sl -> [mkstr loc (Pstr_primitive n (mkvalue_desc t (list_of_meta_list sl))) :: l] @@ -964,7 +1068,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | CtFun loc (TyLab _ lab t) ct -> mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 <:ctyp@loc1< option >> t in + let t = TyApp loc1 (predef_option loc1) t in mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) | CtSig loc t_o ctfl -> diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli index 6c284833..0e6f52cc 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/CleanAst.ml b/camlp4/Camlp4/Struct/CleanAst.ml index ab925054..8354d1c2 100644 --- a/camlp4/Camlp4/Struct/CleanAst.ml +++ b/camlp4/Camlp4/Struct/CleanAst.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/CommentFilter.ml b/camlp4/Camlp4/Struct/CommentFilter.ml index 9dac53fb..f8cb3004 100644 --- a/camlp4/Camlp4/Struct/CommentFilter.ml +++ b/camlp4/Camlp4/Struct/CommentFilter.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/CommentFilter.mli b/camlp4/Camlp4/Struct/CommentFilter.mli index 79ece6a4..1df29f7b 100644 --- a/camlp4/Camlp4/Struct/CommentFilter.mli +++ b/camlp4/Camlp4/Struct/CommentFilter.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/DynAst.ml b/camlp4/Camlp4/Struct/DynAst.ml index 2161e1c9..4bc8a33b 100644 --- a/camlp4/Camlp4/Struct/DynAst.ml +++ b/camlp4/Camlp4/Struct/DynAst.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/DynLoader.ml b/camlp4/Camlp4/Struct/DynLoader.ml index f8e8c22f..00ab05ab 100644 --- a/camlp4/Camlp4/Struct/DynLoader.ml +++ b/camlp4/Camlp4/Struct/DynLoader.ml @@ -1,15 +1,15 @@ (* camlp4r pa_macro.cmo *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2001-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/DynLoader.mli b/camlp4/Camlp4/Struct/DynLoader.mli index 292b705b..7a7dc899 100644 --- a/camlp4/Camlp4/Struct/DynLoader.mli +++ b/camlp4/Camlp4/Struct/DynLoader.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/EmptyError.ml b/camlp4/Camlp4/Struct/EmptyError.ml index 1acb2251..52a50289 100644 --- a/camlp4/Camlp4/Struct/EmptyError.ml +++ b/camlp4/Camlp4/Struct/EmptyError.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -19,4 +19,4 @@ type t = unit; exception E of t; value print _ = assert False; -value to_string _ = assert False; \ No newline at end of file +value to_string _ = assert False; diff --git a/camlp4/Camlp4/Struct/EmptyError.mli b/camlp4/Camlp4/Struct/EmptyError.mli index 9d216623..076ee317 100644 --- a/camlp4/Camlp4/Struct/EmptyError.mli +++ b/camlp4/Camlp4/Struct/EmptyError.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -16,4 +16,4 @@ * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) -include Sig.Error; \ No newline at end of file +include Sig.Error; diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.ml b/camlp4/Camlp4/Struct/EmptyPrinter.ml index 5886809b..11a93cd6 100644 --- a/camlp4/Camlp4/Struct/EmptyPrinter.ml +++ b/camlp4/Camlp4/Struct/EmptyPrinter.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.mli b/camlp4/Camlp4/Struct/EmptyPrinter.mli index f8bf907a..94585b32 100644 --- a/camlp4/Camlp4/Struct/EmptyPrinter.mli +++ b/camlp4/Camlp4/Struct/EmptyPrinter.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml index 69e90303..8c253ff5 100644 --- a/camlp4/Camlp4/Struct/FreeVars.ml +++ b/camlp4/Camlp4/Struct/FreeVars.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/FreeVars.mli b/camlp4/Camlp4/Struct/FreeVars.mli index aac72db0..06d3cc0a 100644 --- a/camlp4/Camlp4/Struct/FreeVars.mli +++ b/camlp4/Camlp4/Struct/FreeVars.mli @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Delete.ml b/camlp4/Camlp4/Struct/Grammar/Delete.ml index 929ac2b4..d8f9f9aa 100644 --- a/camlp4/Camlp4/Struct/Grammar/Delete.ml +++ b/camlp4/Camlp4/Struct/Grammar/Delete.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml index 7889cf07..06ac28f1 100644 --- a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml +++ b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Entry.ml b/camlp4/Camlp4/Struct/Grammar/Entry.ml index 0b39b7ca..4ab0c896 100644 --- a/camlp4/Camlp4/Struct/Grammar/Entry.ml +++ b/camlp4/Camlp4/Struct/Grammar/Entry.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Failed.ml b/camlp4/Camlp4/Struct/Grammar/Failed.ml index b22998bd..a0327b15 100644 --- a/camlp4/Camlp4/Struct/Grammar/Failed.ml +++ b/camlp4/Camlp4/Struct/Grammar/Failed.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Find.ml b/camlp4/Camlp4/Struct/Grammar/Find.ml index 9e7774d1..82bd2f0e 100644 --- a/camlp4/Camlp4/Struct/Grammar/Find.ml +++ b/camlp4/Camlp4/Struct/Grammar/Find.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.ml b/camlp4/Camlp4/Struct/Grammar/Fold.ml index caf8a7a0..99e09550 100644 --- a/camlp4/Camlp4/Struct/Grammar/Fold.ml +++ b/camlp4/Camlp4/Struct/Grammar/Fold.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.mli b/camlp4/Camlp4/Struct/Grammar/Fold.mli index 0b9b22b7..1578ccbd 100644 --- a/camlp4/Camlp4/Struct/Grammar/Fold.mli +++ b/camlp4/Camlp4/Struct/Grammar/Fold.mli @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Insert.ml b/camlp4/Camlp4/Struct/Grammar/Insert.ml index a6cbf0ee..24deb01f 100644 --- a/camlp4/Camlp4/Struct/Grammar/Insert.ml +++ b/camlp4/Camlp4/Struct/Grammar/Insert.ml @@ -1,15 +1,15 @@ (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -256,10 +256,6 @@ module Make (Structure : Structure.S) = struct Some t | None -> None ] | LocAct _ _ | DeadEnd -> None ] - and insert_new = - fun - [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct action [] ] in insert gsymbols tree ; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml index 89bbe884..2c639b2a 100644 --- a/camlp4/Camlp4/Struct/Grammar/Parser.ml +++ b/camlp4/Camlp4/Struct/Grammar/Parser.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -34,9 +34,17 @@ module Make (Structure : Structure.S) = struct value drop_prev_loc = Tools.drop_prev_loc; value add_loc bp parse_fun strm = + let count1 = Stream.count strm in let x = parse_fun strm in - let ep = loc_ep strm in - let loc = Loc.merge bp ep in + let count2 = Stream.count strm in + let loc = + if count1 < count2 then + let ep = loc_ep strm in + Loc.merge bp ep + else + (* If nothing has been consumed, create a 0-length location. *) + Loc.join bp + in (x, loc); value stream_peek_nth strm n = diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.mli b/camlp4/Camlp4/Struct/Grammar/Parser.mli index 7b7cbe5a..74e0fe07 100644 --- a/camlp4/Camlp4/Struct/Grammar/Parser.mli +++ b/camlp4/Camlp4/Struct/Grammar/Parser.mli @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Print.ml b/camlp4/Camlp4/Struct/Grammar/Print.ml index 77000c88..06e09c21 100644 --- a/camlp4/Camlp4/Struct/Grammar/Print.ml +++ b/camlp4/Camlp4/Struct/Grammar/Print.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Print.mli b/camlp4/Camlp4/Struct/Grammar/Print.mli index 9acc836d..b1059a6d 100644 --- a/camlp4/Camlp4/Struct/Grammar/Print.mli +++ b/camlp4/Camlp4/Struct/Grammar/Print.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Search.ml b/camlp4/Camlp4/Struct/Grammar/Search.ml index bc4ed301..226a0d44 100644 --- a/camlp4/Camlp4/Struct/Grammar/Search.ml +++ b/camlp4/Camlp4/Struct/Grammar/Search.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Static.ml b/camlp4/Camlp4/Struct/Grammar/Static.ml index a94c9fa1..02aec0b1 100644 --- a/camlp4/Camlp4/Struct/Grammar/Static.ml +++ b/camlp4/Camlp4/Struct/Grammar/Static.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Structure.ml b/camlp4/Camlp4/Struct/Grammar/Structure.ml index 67b99feb..e2a79b18 100644 --- a/camlp4/Camlp4/Struct/Grammar/Structure.ml +++ b/camlp4/Camlp4/Struct/Grammar/Structure.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Grammar/Tools.ml b/camlp4/Camlp4/Struct/Grammar/Tools.ml index cb63478a..df4b03fe 100644 --- a/camlp4/Camlp4/Struct/Grammar/Tools.ml +++ b/camlp4/Camlp4/Struct/Grammar/Tools.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index 1823ae0a..c7336995 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Loc.ml b/camlp4/Camlp4/Struct/Loc.ml index ac42d4b1..2fd2c910 100644 --- a/camlp4/Camlp4/Struct/Loc.ml +++ b/camlp4/Camlp4/Struct/Loc.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Loc.mli b/camlp4/Camlp4/Struct/Loc.mli index e9016193..c6c523fc 100644 --- a/camlp4/Camlp4/Struct/Loc.mli +++ b/camlp4/Camlp4/Struct/Loc.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Quotation.ml b/camlp4/Camlp4/Struct/Quotation.ml index 65202c87..c9d6169a 100644 --- a/camlp4/Camlp4/Struct/Quotation.ml +++ b/camlp4/Camlp4/Struct/Quotation.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml index 384bba91..26207297 100644 --- a/camlp4/Camlp4/Struct/Token.ml +++ b/camlp4/Camlp4/Struct/Token.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4/Struct/Token.mli b/camlp4/Camlp4/Struct/Token.mli index 812df0e0..d3e866a3 100644 --- a/camlp4/Camlp4/Struct/Token.mli +++ b/camlp4/Camlp4/Struct/Token.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml index a123cc12..ecc64311 100644 --- a/camlp4/Camlp4Bin.ml +++ b/camlp4/Camlp4Bin.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Filters/Camlp4AstLifter.ml b/camlp4/Camlp4Filters/Camlp4AstLifter.ml index 768e4dac..cc594aac 100644 --- a/camlp4/Camlp4Filters/Camlp4AstLifter.ml +++ b/camlp4/Camlp4Filters/Camlp4AstLifter.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml index 3d338c41..3cf570c0 100644 --- a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml +++ b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml index 66c48d7e..205afa92 100644 --- a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) -(* Copyright 2006,2007 Institut National de Recherche en Informatique et *) +(* Copyright 2006-2007 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml index 533292de..59199f88 100644 --- a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml +++ b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml index 52b00eb6..de1f910b 100644 --- a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* This module is useless now. Camlp4FoldGenerator handles map too. *) module Id = struct value name = "Camlp4MapGenerator"; diff --git a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml index a49cbf32..b716d5af 100644 --- a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4; open PreCast; module MapTy = Map.Make String; diff --git a/camlp4/Camlp4Filters/Camlp4Profiler.ml b/camlp4/Camlp4Filters/Camlp4Profiler.ml index 18008516..99335cc8 100644 --- a/camlp4/Camlp4Filters/Camlp4Profiler.ml +++ b/camlp4/Camlp4Filters/Camlp4Profiler.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Filters/Camlp4TrashRemover.ml b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml index 07ead66a..d486e2b6 100644 --- a/camlp4/Camlp4Filters/Camlp4TrashRemover.ml +++ b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4AstLoader.ml b/camlp4/Camlp4Parsers/Camlp4AstLoader.ml index 67d04edf..eb0a2139 100644 --- a/camlp4/Camlp4Parsers/Camlp4AstLoader.ml +++ b/camlp4/Camlp4Parsers/Camlp4AstLoader.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml index 7e722818..be4fe60a 100644 --- a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml index 3d64b1ae..6b4e1d8e 100644 --- a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml index f5878fb9..7bdad3c4 100644 --- a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml index 0cb81be9..840bc5ec 100644 --- a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -52,6 +52,7 @@ Added statements: DEFINE = IN __FILE__ __LOCATION__ + LOCATION_OF In patterns: @@ -84,6 +85,10 @@ Added statements: The expression __FILE__ returns the current compiled file name. The expression __LOCATION__ returns the current location of itself. + If used inside a macro, it returns the location where the macro is + called. + The expression (LOCATION_OF parameter) returns the location of the given + macro parameter. It cannot be used outside a macro definition. *) @@ -151,6 +156,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> try List.assoc x env with [ Not_found -> super#expr e ] + | <:expr@_loc< LOCATION_OF $lid:x$ >> | <:expr@_loc< LOCATION_OF $uid:x$ >> as e -> + try + let loc = Ast.loc_of_expr (List.assoc x env) in + let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc in + <:expr< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:expr< True >> else <:expr< False >> $) >> + with [ Not_found -> super#expr e ] | e -> super#expr e ]; method patt = @@ -387,15 +401,6 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | "DEFINE"; i = LIDENT; "="; def = expr; "IN"; body = expr -> (new subst _loc [(i, def)])#expr body ] ] ; - expr: LEVEL "simple" - [ [ LIDENT "__FILE__" -> <:expr< $`str:Loc.file_name _loc$ >> - | LIDENT "__LOCATION__" -> - let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in - <:expr< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:expr< True >> else <:expr< False >> $) >> ] ] - ; patt: [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; endif -> if is_defined i then p1 else p2 @@ -434,12 +439,20 @@ module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters; open Ast; - value remove_nothings = + (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *) + value map_expr = fun [ <:expr< $e$ NOTHING >> | <:expr< fun $ <:patt< NOTHING >> $ -> $e$ >> -> e + | <:expr@_loc< $lid:"__FILE__"$ >> -> <:expr< $`str:Loc.file_name _loc$ >> + | <:expr@_loc< $lid:"__LOCATION__"$ >> -> + let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in + <:expr< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:expr< True >> else <:expr< False >> $) >> | e -> e]; - register_str_item_filter (Ast.map_expr remove_nothings)#str_item; + register_str_item_filter (Ast.map_expr map_expr)#str_item; end; diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml index c033a22c..eace67b4 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml index 0e0d9897..bbec29b9 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -158,6 +158,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct DELETE_RULE Gram expr: SELF; ":="; SELF; dummy END; DELETE_RULE Gram expr: "~"; a_LIDENT; ":"; SELF END; DELETE_RULE Gram expr: "?"; a_LIDENT; ":"; SELF END; + DELETE_RULE Gram constructor_declarations: a_UIDENT; ":"; ctyp END; (* Some other DELETE_RULE are after the grammar *) value clear = Gram.Entry.clear; @@ -384,6 +385,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >> | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >> | "("; ")" -> <:patt< () >> + | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >> + | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" -> + <:patt< ((module $m$) : (module $pt$)) >> | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> | "("; p = patt; ")" -> <:patt< $p$ >> | "_" -> <:patt< _ >> @@ -427,8 +431,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct ] ] ; package_type_cstr: - [ [ "type"; i = a_LIDENT; "="; ty = ctyp -> - <:with_constr< type $lid:i$ = $ty$ >> + [ [ "type"; i = ident; "="; ty = ctyp -> + <:with_constr< type $id:i$ = $ty$ >> ] ] ; package_type_cstrs: @@ -538,6 +542,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | t = ctyp LEVEL "ctyp1" -> t ] ] ; + constructor_declarations: + [ [ s = a_UIDENT; ":"; t = constructor_arg_list ; "->" ; ret = ctyp -> + <:ctyp< $uid:s$ : ($t$ -> $ret$) >> + | s = a_UIDENT; ":"; ret = constructor_arg_list -> + match Ast.list_of_ctyp ret [] with + [ [c] -> <:ctyp< $uid:s$ : $c$ >> + | _ -> raise (Stream.Error "invalid generalized constructor type") ] + ] ] + ; semi: [ [ ";;" -> () | -> () ] ] ; @@ -559,17 +572,35 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | t = type_parameter -> fun acc -> <:ctyp< $acc$ $t$ >> ] ] ; + + optional_type_parameter: + [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >> + | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag + | "+"; "_" -> Ast.TyAnP _loc + | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >> + | "-"; "_" -> Ast.TyAnM _loc + | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> + | "_" -> Ast.TyAny _loc + | "'"; i = a_ident -> <:ctyp< '$lid:i$ >> + + ] ] + ; + type_ident_and_parameters: - [ [ "("; tpl = LIST1 type_parameter SEP ","; ")"; i = a_LIDENT -> (i, tpl) - | t = type_parameter; i = a_LIDENT -> (i, [t]) + [ [ "("; tpl = LIST1 optional_type_parameter SEP ","; ")"; i = a_LIDENT -> (i, tpl) + | t = optional_type_parameter; i = a_LIDENT -> (i, [t]) | i = a_LIDENT -> (i, []) ] ] ; type_kind: [ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >> - | t = TRY [OPT "|"; t = constructor_declarations; - test_not_dot_nor_lparen -> t] -> - <:ctyp< [ $t$ ] >> + | (x, t) = TRY [x = OPT "|"; t = constructor_declarations; + test_not_dot_nor_lparen -> (x, t)] -> + (* If there is no "|" and [t] is an antiquotation, + then it is not a sum type. *) + match (x, t) with + [ (None, Ast.TyAnt _) -> t + | _ -> <:ctyp< [ $t$ ] >> ] | t = TRY ctyp -> <:ctyp< $t$ >> | t = TRY ctyp; "="; "private"; tk = type_kind -> <:ctyp< $t$ == private $tk$ >> diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml index 94a2bdb2..082ac836 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 1998-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml index e56ab361..02c89f81 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index b8eaf0bd..ed6dad06 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -303,6 +303,15 @@ New syntax:\ value stopped_at _loc = Some (Loc.move_line 1 _loc) (* FIXME be more precise *); + value rec generalized_type_of_type = + fun + [ <:ctyp< $t1$ -> $t2$ >> -> + let (tl, rt) = generalized_type_of_type t2 in + ([t1 :: tl], rt) + | t -> + ([], t) ] + ; + value symbolchar = let list = ['$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; @@ -361,7 +370,7 @@ New syntax:\ parser [ [: `((KEYWORD "(", _) as tok); xs :] -> match xs with parser - [ [: `(KEYWORD ("mod"|"land"|"lor"|"lxor"|"lsl"|"lsr"|"asr" as i), _loc); + [ [: `(KEYWORD ("or"|"mod"|"land"|"lor"|"lxor"|"lsl"|"lsr"|"asr" as i), _loc); `(KEYWORD ")", _); xs :] -> [: `(LIDENT i, _loc); infix_kwds_filter xs :] | [: xs :] -> @@ -521,7 +530,8 @@ New syntax:\ | i = module_longident_with_app -> <:module_type< $id:i$ >> | "'"; i = a_ident -> <:module_type< ' $i$ >> | "("; mt = SELF; ")" -> <:module_type< $mt$ >> - | "module"; "type"; "of"; me = module_expr -> <:module_type< module type of $me$ >> ] ] + | "module"; "type"; "of"; me = module_expr -> + <:module_type< module type of $me$ >> ] ] ; sig_item: [ "top" @@ -782,9 +792,9 @@ New syntax:\ [ RIGHTA [ TRY ["("; "type"]; i = a_LIDENT; ")"; e = SELF -> <:expr< fun (type $i$) -> $e$ >> - | p = TRY labeled_ipatt; e = SELF -> + | bi = TRY cvalue_binding -> bi + | p = labeled_ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | bi = cvalue_binding -> bi ] ] ; match_case: @@ -891,6 +901,9 @@ New syntax:\ | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >> | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >> | "("; ")" -> <:patt< () >> + | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >> + | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" -> + <:patt< ((module $m$) : (module $pt$)) >> | "("; p = SELF; ")" -> p | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> @@ -959,6 +972,9 @@ New syntax:\ <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag | "("; ")" -> <:patt< () >> + | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >> + | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" -> + <:patt< ((module $m$) : (module $pt$)) >> | "("; p = SELF; ")" -> p | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> @@ -977,6 +993,8 @@ New syntax:\ ; label_ipatt_list: [ [ p1 = label_ipatt; ";"; p2 = SELF -> <:patt< $p1$ ; $p2$ >> + | p1 = label_ipatt; ";"; "_" -> <:patt< $p1$ ; _ >> + | p1 = label_ipatt; ";"; "_"; ";" -> <:patt< $p1$ ; _ >> | p1 = label_ipatt; ";" -> p1 | p1 = label_ipatt -> p1 ] ]; @@ -1010,7 +1028,7 @@ New syntax:\ [ [ t = ctyp -> t ] ] ; type_ident_and_parameters: - [ [ i = a_LIDENT; tpl = LIST0 type_parameter -> (i, tpl) ] ] + [ [ i = a_LIDENT; tpl = LIST0 optional_type_parameter -> (i, tpl) ] ] ; type_longident_and_parameters: [ [ i = type_longident; tpl = type_parameters -> tpl <:ctyp< $id:i$ >> @@ -1023,6 +1041,7 @@ New syntax:\ | -> fun t -> t ] ] ; + type_parameter: [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag @@ -1030,6 +1049,20 @@ New syntax:\ | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >> | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> ] ] ; + optional_type_parameter: + [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >> + | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag + | "'"; i = a_ident -> <:ctyp< '$lid:i$ >> + | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >> + | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> + | "+"; "_" -> Ast.TyAnP _loc + | "-"; "_" -> Ast.TyAnM _loc + | "_" -> Ast.TyAny _loc + + ] ] + ; + + ctyp: [ "==" LEFTA [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ] @@ -1111,8 +1144,11 @@ New syntax:\ <:ctyp< $t1$ | $t2$ >> | s = a_UIDENT; "of"; t = constructor_arg_list -> <:ctyp< $uid:s$ of $t$ >> + | s = a_UIDENT; ":"; t = ctyp -> + let (tl, rt) = generalized_type_of_type t in + <:ctyp< $uid:s$ : ($Ast.tyAnd_of_list tl$ -> $rt$) >> | s = a_UIDENT -> - <:ctyp< $uid:s$ >> + <:ctyp< $uid:s$ >> ] ] ; constructor_declaration: @@ -1364,6 +1400,9 @@ New syntax:\ ; cvalue_binding: [ [ "="; e = expr -> e + | ":"; "type"; t1 = unquoted_typevars; "." ; t2 = ctyp ; "="; e = expr -> + let u = Ast.TyTypePol _loc t1 t2 in + <:expr< ($e$ : $u$) >> | ":"; t = poly_type; "="; e = expr -> <:expr< ($e$ : $t$) >> | ":"; t = poly_type; ":>"; t2 = ctyp; "="; e = expr -> match t with @@ -1484,6 +1523,16 @@ New syntax:\ | "'"; i = a_ident -> <:ctyp< '$lid:i$ >> ] ] ; + unquoted_typevars: + [ LEFTA + [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> + | `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag + | i = a_ident -> <:ctyp< $lid:i$ >> + ] ] + ; + row_field: [ [ `ANTIQUOT (""|"typ" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> @@ -1741,13 +1790,19 @@ New syntax:\ ; str_item_quot: [ [ "#"; n = a_LIDENT; dp = opt_expr -> <:str_item< # $n$ $dp$ >> - | st1 = str_item; semi; st2 = SELF -> <:str_item< $st1$; $st2$ >> + | st1 = str_item; semi; st2 = SELF -> + match st2 with + [ <:str_item<>> -> st1 + | _ -> <:str_item< $st1$; $st2$ >> ] | st = str_item -> st | -> <:str_item<>> ] ] ; sig_item_quot: [ [ "#"; n = a_LIDENT; dp = opt_expr -> <:sig_item< # $n$ $dp$ >> - | sg1 = sig_item; semi; sg2 = SELF -> <:sig_item< $sg1$; $sg2$ >> + | sg1 = sig_item; semi; sg2 = SELF -> + match sg2 with + [ <:sig_item<>> -> sg1 + | _ -> <:sig_item< $sg1$; $sg2$ >> ] | sg = sig_item -> sg | -> <:sig_item<>> ] ] ; @@ -1832,12 +1887,17 @@ New syntax:\ ; class_str_item_quot: [ [ x1 = class_str_item; semi; x2 = SELF -> - <:class_str_item< $x1$; $x2$ >> + match x2 with + [ <:class_str_item<>> -> x1 + | _ -> <:class_str_item< $x1$; $x2$ >> ] | x = class_str_item -> x | -> <:class_str_item<>> ] ] ; class_sig_item_quot: - [ [ x1 = class_sig_item; semi; x2 = SELF -> <:class_sig_item< $x1$; $x2$ >> + [ [ x1 = class_sig_item; semi; x2 = SELF -> + match x2 with + [ <:class_sig_item<>> -> x1 + | _ -> <:class_sig_item< $x1$; $x2$ >> ] | x = class_sig_item -> x | -> <:class_sig_item<>> ] ] ; diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml index 97747d44..2bdab6bf 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 1998-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml index 07d2a01e..2e32bcd8 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml index 76e67f41..3cf80b56 100644 --- a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml +++ b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml index fb225a58..81680c6b 100644 --- a/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml +++ b/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml @@ -1,15 +1,15 @@ open Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Printers/Camlp4AstDumper.ml b/camlp4/Camlp4Printers/Camlp4AstDumper.ml index f89fed40..b9adf908 100644 --- a/camlp4/Camlp4Printers/Camlp4AstDumper.ml +++ b/camlp4/Camlp4Printers/Camlp4AstDumper.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml b/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml index eb6b9a24..4b2787ef 100644 --- a/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml +++ b/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Printers/Camlp4NullDumper.ml b/camlp4/Camlp4Printers/Camlp4NullDumper.ml index 0e02b66d..77105dc7 100644 --- a/camlp4/Camlp4Printers/Camlp4NullDumper.ml +++ b/camlp4/Camlp4Printers/Camlp4NullDumper.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml b/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml index 174e5ad1..872be925 100644 --- a/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml +++ b/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml b/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml index 487b8627..63fd2a1c 100644 --- a/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml +++ b/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml b/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml index bd5af1f5..4f8bf71d 100644 --- a/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml +++ b/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml index ce772d1d..d913efcc 100644 --- a/camlp4/Camlp4Top/Rprint.ml +++ b/camlp4/Camlp4Top/Rprint.ml @@ -1,15 +1,15 @@ (* camlp4r *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -246,10 +246,14 @@ and print_simple_out_type ppf = fprintf ppf "@[<1>(%a)@]" print_out_type ty ] in print_tkind ppf -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> +and print_out_constr ppf (name, tyl, ret) = + match (tyl,ret) with + [ ([], None) -> fprintf ppf "%s" name + | ([], Some r) -> fprintf ppf "@[<2>%s:@ %a@]" name print_out_type r + | (_,Some r) -> + fprintf ppf "@[<2>%s:@ %a -> %a@]" name + (print_typlist print_out_type " and") tyl print_out_type r + | (_,None) -> fprintf ppf "@[<2>%s of@ %a@]" name (print_typlist print_out_type " and") tyl ] and print_out_label ppf (name, mut, arg) = @@ -392,7 +396,7 @@ and print_out_sig_item ppf = (if vir_flag then " virtual" else "") print_out_class_params params name Toploop.print_out_class_type.val clt | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) + fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None) | Osig_modtype name Omty_abstract -> fprintf ppf "@[<2>module type %s@]" name | Osig_modtype name mty -> diff --git a/camlp4/Camlp4Top/Top.ml b/camlp4/Camlp4Top/Top.ml index dcd3aa46..0e07eb21 100644 --- a/camlp4/Camlp4Top/Top.ml +++ b/camlp4/Camlp4Top/Top.ml @@ -1,15 +1,15 @@ (* camlp4r q_MLast.cmo *) (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -60,45 +60,31 @@ value initialization = lazy begin else () end; -value lookup x xs = try Some (List.assq x xs) with [ Not_found -> None ]; - -value wrap parse_fun = - let token_streams = ref [] in - let cleanup lb = - try token_streams.val := List.remove_assq lb token_streams.val - with [ Not_found -> () ] - in - fun lb -> - let () = Lazy.force initialization in - let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in - let token_stream = - match lookup lb token_streams.val with - [ None -> - let not_filtered_token_stream = Lexer.from_lexbuf lb in - let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in - do { token_streams.val := [ (lb,token_stream) :: token_streams.val ]; token_stream } - | Some token_stream -> token_stream ] - in try - match token_stream with parser - [ [: `(EOI, _) :] -> raise End_of_file - | [: :] -> parse_fun token_stream ] - with - [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) - as x -> (cleanup lb; raise x) - | x -> - let x = - match x with - [ Loc.Exc_located loc x -> do { +value wrap parse_fun lb = + let () = Lazy.force initialization in + let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in + let not_filtered_token_stream = Lexer.from_lexbuf lb in + let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in + try + match token_stream with parser + [ [: `(EOI, _) :] -> raise End_of_file + | [: :] -> parse_fun token_stream ] + with + [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) + as x -> raise x + | x -> + let x = + match x with + [ Loc.Exc_located loc x -> do { Toploop.print_location Format.err_formatter (Loc.to_ocaml_location loc); x } - | x -> x ] - in - do { - cleanup lb; - Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; - raise Exit - } ]; + | x -> x ] + in + do { + Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; + raise Exit + } ]; value toplevel_phrase token_stream = match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with diff --git a/camlp4/Camlp4_config.ml b/camlp4/Camlp4_config.ml index 745930b7..a055e6ca 100644 --- a/camlp4/Camlp4_config.ml +++ b/camlp4/Camlp4_config.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) @@ -32,8 +32,8 @@ let verbose = ref false;; let antiquotations = ref false;; let quotations = ref true;; let inter_phrases = ref None;; -let camlp4_ast_impl_magic_number = "Camlp42006M001";; -let camlp4_ast_intf_magic_number = "Camlp42006N001";; +let camlp4_ast_impl_magic_number = "Camlp42006M002";; +let camlp4_ast_intf_magic_number = "Camlp42006N002";; let ocaml_ast_intf_magic_number = Camlp4_import.Config.ast_intf_magic_number;; let ocaml_ast_impl_magic_number = Camlp4_import.Config.ast_impl_magic_number;; let current_input_file = ref "";; diff --git a/camlp4/Camlp4_config.mli b/camlp4/Camlp4_config.mli index 17592084..cbc16322 100644 --- a/camlp4/Camlp4_config.mli +++ b/camlp4/Camlp4_config.mli @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/boot/.cvsignore b/camlp4/boot/.cvsignore deleted file mode 100644 index 85599a4b..00000000 --- a/camlp4/boot/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -*.cm[oia] -camlp4 -camlp4o -camlp4r -SAVED diff --git a/camlp4/boot/.ignore b/camlp4/boot/.ignore new file mode 100644 index 00000000..03db1487 --- /dev/null +++ b/camlp4/boot/.ignore @@ -0,0 +1,4 @@ +camlp4 +camlp4o +camlp4r +SAVED diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 2dc65813..3967ba21 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -2,15 +2,15 @@ module Debug : sig (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -28,15 +28,15 @@ module Debug : struct (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -110,15 +110,15 @@ module Options : sig (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -142,15 +142,15 @@ module Options : struct (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -357,15 +357,15 @@ module Sig = (* camlp4r *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -671,145 +671,83 @@ module Sig = class map : object ('self_type) method string : string -> string - method list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method override_flag : override_flag -> override_flag - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method unknown : 'a. 'a -> 'a - end (** Fold style traversal *) class fold : object ('self_type) method string : string -> 'self_type - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type - method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end end @@ -850,6 +788,19 @@ module Sig = (** The inner module for locations *) module Loc : Loc + (****************************************************************************) + (* *) + (* OCaml *) + (* *) + (* 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 GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) + (* *) + (****************************************************************************) type loc = Loc. t @@ -918,12 +869,19 @@ module Sig = TyPol of loc * ctyp * ctyp | (* ! t . t *) (* ! 'a . list 'a -> 'a *) + TyTypePol of loc * ctyp * ctyp + | (* type t . t *) + (* type a . list a -> a *) TyQuo of loc * string | (* 's *) TyQuP of loc * string | (* +'s *) TyQuM of loc * string | (* -'s *) + TyAnP of loc + | (* +_ *) + TyAnM of loc + | (* -_ *) TyVrn of loc * string | (* `s *) TyRec of loc * ctyp @@ -1023,7 +981,9 @@ module Sig = PaVrn of loc * string | (* `s *) PaLaz of loc * patt - and (* lazy p *) + | (* lazy p *) + PaMod of loc * string + and (* (module M) *) expr = | ExNil of loc | ExId of loc * ident @@ -1537,144 +1497,82 @@ module Sig = class map : object ('self_type) method string : string -> string - method list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method override_flag : override_flag -> override_flag - method unknown : 'a. 'a -> 'a - end class fold : object ('self_type) method string : string -> 'self_type - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type - method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end val map_expr : (expr -> expr) -> map @@ -1878,9 +1776,12 @@ module Sig = | TyObj of loc * ctyp * row_var_flag | TyOlb of loc * string * ctyp | TyPol of loc * ctyp * ctyp + | TyTypePol of loc * ctyp * ctyp | TyQuo of loc * string | TyQuP of loc * string | TyQuM of loc * string + | TyAnP of loc + | TyAnM of loc | TyVrn of loc * string | TyRec of loc * ctyp | TyCol of loc * ctyp * ctyp @@ -1931,6 +1832,7 @@ module Sig = | PaTyp of loc * ident | PaVrn of loc * string | PaLaz of loc * patt + | PaMod of loc * string and expr = | ExNil of loc | ExId of loc * ident @@ -3880,6 +3782,15 @@ module Struct = pos_bol = pos.pos_cnum - chars; } + let cvt_int_literal s = - (int_of_string ("-" ^ s)) + + let cvt_int32_literal s = Int32.neg (Int32.of_string ("-" ^ s)) + + let cvt_int64_literal s = Int64.neg (Int64.of_string ("-" ^ s)) + + let cvt_nativeint_literal s = + Nativeint.neg (Nativeint.of_string ("-" ^ s)) + let err error loc = raise (Loc.Exc_located (loc, (Error.E error))) @@ -6473,7 +6384,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in - (try INT ((int_of_string i), i) + (try INT ((cvt_int_literal i), i) with | Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf)) @@ -6492,7 +6403,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in - (try INT32 ((Int32.of_string i), i) + (try INT32 ((cvt_int32_literal i), i) with | Failure _ -> err (Literal_overflow "int32") @@ -6502,7 +6413,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in - (try INT64 ((Int64.of_string i), i) + (try INT64 ((cvt_int64_literal i), i) with | Failure _ -> err (Literal_overflow "int64") @@ -6512,7 +6423,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in - (try NATIVEINT ((Nativeint.of_string i), i) + (try NATIVEINT ((cvt_nativeint_literal i), i) with | Failure _ -> err (Literal_overflow "nativeint") @@ -7030,6 +6941,7 @@ module Struct = | Ast.PaLab (_, _, p) -> is_irrefut_patt p | Ast.PaLaz (_, p) -> is_irrefut_patt p | Ast.PaId (_, _) -> false + | Ast.PaMod (_, _) -> true | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) | Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) | Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _) @@ -8138,6 +8050,20 @@ module Struct = (Ast.IdUid (_loc, "TyVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) + | Ast.TyAnM x0 -> + Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyAnM")))))), + (meta_loc _loc x0)) + | Ast.TyAnP x0 -> + Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyAnP")))))), + (meta_loc _loc x0)) | Ast.TyQuM (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -8165,6 +8091,17 @@ module Struct = (Ast.IdUid (_loc, "TyQuo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) + | Ast.TyTypePol (x0, x1, x2) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyTypePol")))))), + (meta_loc _loc x0))), + (meta_ctyp _loc x1))), + (meta_ctyp _loc x2)) | Ast.TyPol (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -9093,6 +9030,15 @@ module Struct = (Ast.IdUid (_loc, "OvOverride"))))) and meta_patt _loc = function + | Ast.PaMod (x0, x1) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "PaMod")))))), + (meta_loc _loc x0))), + (meta_string _loc x1)) | Ast.PaLaz (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -10433,6 +10379,20 @@ module Struct = (Ast.IdUid (_loc, "TyVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) + | Ast.TyAnM x0 -> + Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyAnM")))))), + (meta_loc _loc x0)) + | Ast.TyAnP x0 -> + Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyAnP")))))), + (meta_loc _loc x0)) | Ast.TyQuM (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -10460,6 +10420,17 @@ module Struct = (Ast.IdUid (_loc, "TyQuo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) + | Ast.TyTypePol (x0, x1, x2) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "TyTypePol")))))), + (meta_loc _loc x0))), + (meta_ctyp _loc x1))), + (meta_ctyp _loc x2)) | Ast.TyPol (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -11388,6 +11359,15 @@ module Struct = (Ast.IdUid (_loc, "OvOverride"))))) and meta_patt _loc = function + | Ast.PaMod (x0, x1) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "PaMod")))))), + (meta_loc _loc x0))), + (meta_string _loc x1)) | Ast.PaLaz (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -12096,7 +12076,6 @@ module Struct = class map = object ((o : 'self_type)) method string : string -> string = o#unknown - method list : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list = @@ -12106,7 +12085,6 @@ module Struct = | _x :: _x_i1 -> let _x = _f_a o _x in let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1 - method with_constr : with_constr -> with_constr = function | WcNil _x -> let _x = o#loc _x in WcNil _x @@ -12134,13 +12112,11 @@ module Struct = | WcAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in WcAnt (_x, _x_i1) - method virtual_flag : virtual_flag -> virtual_flag = function | ViVirtual -> ViVirtual | ViNil -> ViNil | ViAnt _x -> let _x = o#string _x in ViAnt _x - method str_item : str_item -> str_item = function | StNil _x -> let _x = o#loc _x in StNil _x @@ -12203,7 +12179,6 @@ module Struct = | StAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in StAnt (_x, _x_i1) - method sig_item : sig_item -> sig_item = function | SgNil _x -> let _x = o#loc _x in SgNil _x @@ -12261,19 +12236,16 @@ module Struct = | SgAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in SgAnt (_x, _x_i1) - method row_var_flag : row_var_flag -> row_var_flag = function | RvRowVar -> RvRowVar | RvNil -> RvNil | RvAnt _x -> let _x = o#string _x in RvAnt _x - method rec_flag : rec_flag -> rec_flag = function | ReRecursive -> ReRecursive | ReNil -> ReNil | ReAnt _x -> let _x = o#string _x in ReAnt _x - method rec_binding : rec_binding -> rec_binding = function | RbNil _x -> let _x = o#loc _x in RbNil _x @@ -12289,13 +12261,11 @@ module Struct = | RbAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in RbAnt (_x, _x_i1) - method private_flag : private_flag -> private_flag = function | PrPrivate -> PrPrivate | PrNil -> PrNil | PrAnt _x -> let _x = o#string _x in PrAnt _x - method patt : patt -> patt = function | PaNil _x -> let _x = o#loc _x in PaNil _x @@ -12391,19 +12361,19 @@ module Struct = | PaLaz (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1) - + | PaMod (_x, _x_i1) -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1) method override_flag : override_flag -> override_flag = function | OvOverride -> OvOverride | OvNil -> OvNil | OvAnt _x -> let _x = o#string _x in OvAnt _x - method mutable_flag : mutable_flag -> mutable_flag = function | MuMutable -> MuMutable | MuNil -> MuNil | MuAnt _x -> let _x = o#string _x in MuAnt _x - method module_type : module_type -> module_type = function | MtNil _x -> let _x = o#loc _x in MtNil _x @@ -12433,7 +12403,6 @@ module Struct = | MtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1) - method module_expr : module_expr -> module_expr = function | MeNil _x -> let _x = o#loc _x in MeNil _x @@ -12465,7 +12434,6 @@ module Struct = | MeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1) - method module_binding : module_binding -> module_binding = function | MbNil _x -> let _x = o#loc _x in MbNil _x @@ -12488,7 +12456,6 @@ module Struct = | MbAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MbAnt (_x, _x_i1) - method meta_option : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> @@ -12498,7 +12465,6 @@ module Struct = | ONone -> ONone | OSome _x -> let _x = _f_a o _x in OSome _x | OAnt _x -> let _x = o#string _x in OAnt _x - method meta_list : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> @@ -12511,13 +12477,11 @@ module Struct = let _x_i1 = o#meta_list _f_a _x_i1 in LCons (_x, _x_i1) | LAnt _x -> let _x = o#string _x in LAnt _x - method meta_bool : meta_bool -> meta_bool = function | BTrue -> BTrue | BFalse -> BFalse | BAnt _x -> let _x = o#string _x in BAnt _x - method match_case : match_case -> match_case = function | McNil _x -> let _x = o#loc _x in McNil _x @@ -12535,9 +12499,7 @@ module Struct = | McAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in McAnt (_x, _x_i1) - method loc : loc -> loc = o#unknown - method ident : ident -> ident = function | IdAcc (_x, _x_i1, _x_i2) -> @@ -12557,7 +12519,6 @@ module Struct = | IdAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdAnt (_x, _x_i1) - method expr : expr -> expr = function | ExNil _x -> let _x = o#loc _x in ExNil _x @@ -12726,13 +12687,11 @@ module Struct = | ExPkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1) - method direction_flag : direction_flag -> direction_flag = function | DiTo -> DiTo | DiDownto -> DiDownto | DiAnt _x -> let _x = o#string _x in DiAnt _x - method ctyp : ctyp -> ctyp = function | TyNil _x -> let _x = o#loc _x in TyNil _x @@ -12788,6 +12747,11 @@ module Struct = let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyPol (_x, _x_i1, _x_i2) + | TyTypePol (_x, _x_i1, _x_i2) -> + let _x = o#loc _x in + let _x_i1 = o#ctyp _x_i1 in + let _x_i2 = o#ctyp _x_i2 + in TyTypePol (_x, _x_i1, _x_i2) | TyQuo (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuo (_x, _x_i1) @@ -12797,6 +12761,8 @@ module Struct = | TyQuM (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuM (_x, _x_i1) + | TyAnP _x -> let _x = o#loc _x in TyAnP _x + | TyAnM _x -> let _x = o#loc _x in TyAnM _x | TyVrn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyVrn (_x, _x_i1) @@ -12871,7 +12837,6 @@ module Struct = | TyAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1) - method class_type : class_type -> class_type = function | CtNil _x -> let _x = o#loc _x in CtNil _x @@ -12909,7 +12874,6 @@ module Struct = | CtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1) - method class_str_item : class_str_item -> class_str_item = function | CrNil _x -> let _x = o#loc _x in CrNil _x @@ -12961,7 +12925,6 @@ module Struct = | CrAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CrAnt (_x, _x_i1) - method class_sig_item : class_sig_item -> class_sig_item = function | CgNil _x -> let _x = o#loc _x in CgNil _x @@ -12999,7 +12962,6 @@ module Struct = | CgAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CgAnt (_x, _x_i1) - method class_expr : class_expr -> class_expr = function | CeNil _x -> let _x = o#loc _x in CeNil _x @@ -13047,7 +13009,6 @@ module Struct = | CeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1) - method binding : binding -> binding = function | BiNil _x -> let _x = o#loc _x in BiNil _x @@ -13062,15 +13023,12 @@ module Struct = | BiAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in BiAnt (_x, _x_i1) - method unknown : 'a. 'a -> 'a = fun x -> x - end class fold = object ((o : 'self_type)) method string : string -> 'self_type = o#unknown - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type = @@ -13079,7 +13037,6 @@ module Struct = | [] -> o | _x :: _x_i1 -> let o = _f_a o _x in let o = o#list _f_a _x_i1 in o - method with_constr : with_constr -> 'self_type = function | WcNil _x -> let o = o#loc _x in o @@ -13101,13 +13058,11 @@ module Struct = let o = o#with_constr _x_i2 in o | WcAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method virtual_flag : virtual_flag -> 'self_type = function | ViVirtual -> o | ViNil -> o | ViAnt _x -> let o = o#string _x in o - method str_item : str_item -> 'self_type = function | StNil _x -> let o = o#loc _x in o @@ -13155,7 +13110,6 @@ module Struct = let o = o#binding _x_i2 in o | StAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method sig_item : sig_item -> 'self_type = function | SgNil _x -> let o = o#loc _x in o @@ -13198,19 +13152,16 @@ module Struct = let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | SgAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method row_var_flag : row_var_flag -> 'self_type = function | RvRowVar -> o | RvNil -> o | RvAnt _x -> let o = o#string _x in o - method rec_flag : rec_flag -> 'self_type = function | ReRecursive -> o | ReNil -> o | ReAnt _x -> let o = o#string _x in o - method rec_binding : rec_binding -> 'self_type = function | RbNil _x -> let o = o#loc _x in o @@ -13223,13 +13174,11 @@ module Struct = let o = o#ident _x_i1 in let o = o#expr _x_i2 in o | RbAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method private_flag : private_flag -> 'self_type = function | PrPrivate -> o | PrNil -> o | PrAnt _x -> let o = o#string _x in o - method patt : patt -> 'self_type = function | PaNil _x -> let o = o#loc _x in o @@ -13298,19 +13247,18 @@ module Struct = let o = o#loc _x in let o = o#string _x_i1 in o | PaLaz (_x, _x_i1) -> let o = o#loc _x in let o = o#patt _x_i1 in o - + | PaMod (_x, _x_i1) -> + let o = o#loc _x in let o = o#string _x_i1 in o method override_flag : override_flag -> 'self_type = function | OvOverride -> o | OvNil -> o | OvAnt _x -> let o = o#string _x in o - method mutable_flag : mutable_flag -> 'self_type = function | MuMutable -> o | MuNil -> o | MuAnt _x -> let o = o#string _x in o - method module_type : module_type -> 'self_type = function | MtNil _x -> let o = o#loc _x in o @@ -13333,7 +13281,6 @@ module Struct = let o = o#loc _x in let o = o#module_expr _x_i1 in o | MtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method module_expr : module_expr -> 'self_type = function | MeNil _x -> let o = o#loc _x in o @@ -13358,7 +13305,6 @@ module Struct = let o = o#loc _x in let o = o#expr _x_i1 in o | MeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method module_binding : module_binding -> 'self_type = function | MbNil _x -> let o = o#loc _x in o @@ -13377,7 +13323,6 @@ module Struct = let o = o#module_type _x_i2 in o | MbAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> @@ -13387,7 +13332,6 @@ module Struct = | ONone -> o | OSome _x -> let o = _f_a o _x in o | OAnt _x -> let o = o#string _x in o - method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> @@ -13399,13 +13343,11 @@ module Struct = let o = _f_a o _x in let o = o#meta_list _f_a _x_i1 in o | LAnt _x -> let o = o#string _x in o - method meta_bool : meta_bool -> 'self_type = function | BTrue -> o | BFalse -> o | BAnt _x -> let o = o#string _x in o - method match_case : match_case -> 'self_type = function | McNil _x -> let o = o#loc _x in o @@ -13419,9 +13361,7 @@ module Struct = let o = o#expr _x_i2 in let o = o#expr _x_i3 in o | McAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method loc : loc -> 'self_type = o#unknown - method ident : ident -> 'self_type = function | IdAcc (_x, _x_i1, _x_i2) -> @@ -13436,7 +13376,6 @@ module Struct = let o = o#loc _x in let o = o#string _x_i1 in o | IdAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method expr : expr -> 'self_type = function | ExNil _x -> let o = o#loc _x in o @@ -13559,13 +13498,11 @@ module Struct = let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExPkg (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o - method direction_flag : direction_flag -> 'self_type = function | DiTo -> o | DiDownto -> o | DiAnt _x -> let o = o#string _x in o - method ctyp : ctyp -> 'self_type = function | TyNil _x -> let o = o#loc _x in o @@ -13610,12 +13547,17 @@ module Struct = | TyPol (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o + | TyTypePol (_x, _x_i1, _x_i2) -> + let o = o#loc _x in + let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyQuo (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuP (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuM (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o + | TyAnP _x -> let o = o#loc _x in o + | TyAnM _x -> let o = o#loc _x in o | TyVrn (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyRec (_x, _x_i1) -> @@ -13668,7 +13610,6 @@ module Struct = let o = o#loc _x in let o = o#module_type _x_i1 in o | TyAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_type : class_type -> 'self_type = function | CtNil _x -> let o = o#loc _x in o @@ -13697,7 +13638,6 @@ module Struct = let o = o#class_type _x_i2 in o | CtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_str_item : class_str_item -> 'self_type = function | CrNil _x -> let o = o#loc _x in o @@ -13739,7 +13679,6 @@ module Struct = let o = o#ctyp _x_i3 in o | CrAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_sig_item : class_sig_item -> 'self_type = function | CgNil _x -> let o = o#loc _x in o @@ -13770,7 +13709,6 @@ module Struct = let o = o#ctyp _x_i3 in o | CgAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_expr : class_expr -> 'self_type = function | CeNil _x -> let o = o#loc _x in o @@ -13807,7 +13745,6 @@ module Struct = let o = o#class_expr _x_i2 in o | CeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method binding : binding -> 'self_type = function | BiNil _x -> let o = o#loc _x in o @@ -13819,57 +13756,43 @@ module Struct = let o = o#patt _x_i1 in let o = o#expr _x_i2 in o | BiAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method unknown : 'a. 'a -> 'self_type = fun _ -> o - end let map_expr f = object inherit map as super - method expr = fun x -> f (super#expr x) - end let map_patt f = object inherit map as super - method patt = fun x -> f (super#patt x) - end let map_ctyp f = object inherit map as super - method ctyp = fun x -> f (super#ctyp x) - end let map_str_item f = object inherit map as super - method str_item = fun x -> f (super#str_item x) - end let map_sig_item f = object inherit map as super - method sig_item = fun x -> f (super#sig_item x) - end let map_loc f = object inherit map as super - method loc = fun x -> f (super#loc x) - end end @@ -14470,9 +14393,9 @@ module Struct = | TyAnt (loc, _) -> error loc "antiquotation not allowed here" | TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) | TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) | - TyQuP (_, _) | TyDcl (_, _, _, _, _) | - TyObj (_, _, (RvAnt _)) | TyNil _ | TyTup (_, _) -> - assert false + TyQuP (_, _) | TyDcl (_, _, _, _, _) | TyAnP _ | TyAnM _ | + TyTypePol (_, _, _) | TyObj (_, _, (RvAnt _)) | TyNil _ | + TyTup (_, _) -> assert false and row_field = function | Ast.TyNil _ -> [] @@ -14499,7 +14422,7 @@ module Struct = match wc with | Ast.WcNil _ -> acc | Ast.WcTyp (_, (Ast.TyId (_, (Ast.IdLid (_, id)))), ct) -> - (id, (ctyp ct)) :: acc + (Lident id, (ctyp ct)) :: acc | Ast.WcAnd (_, wc1, wc2) -> package_type_constraints wc1 (package_type_constraints wc2 acc) @@ -14546,10 +14469,16 @@ module Struct = let mkvariant = function | Ast.TyId (loc, (Ast.IdUid (_, s))) -> - ((conv_con s), [], (mkloc loc)) + ((conv_con s), [], None, (mkloc loc)) | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) -> - ((conv_con s), (List.map ctyp (list_of_ctyp t [])), + ((conv_con s), (List.map ctyp (list_of_ctyp t [])), None, (mkloc loc)) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), + (Ast.TyArr (_, t, u))) -> + ((conv_con s), (List.map ctyp (list_of_ctyp t [])), + (Some (ctyp u)), (mkloc loc)) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) -> + ((conv_con s), [], (Some (ctyp t)), (mkloc loc)) | _ -> assert false let rec type_decl tl cl loc m pflag = @@ -14616,6 +14545,19 @@ module Struct = | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc | _ -> assert false + let rec optional_type_parameters t acc = + match t with + | Ast.TyApp (_, t1, t2) -> + optional_type_parameters t1 + (optional_type_parameters t2 acc) + | Ast.TyQuP (_, s) -> ((Some s), (true, false)) :: acc + | Ast.TyAnP _loc -> (None, (true, false)) :: acc + | Ast.TyQuM (_, s) -> ((Some s), (false, true)) :: acc + | Ast.TyAnM _loc -> (None, (false, true)) :: acc + | Ast.TyQuo (_, s) -> ((Some s), (false, false)) :: acc + | Ast.TyAny _loc -> (None, (false, false)) :: acc + | _ -> assert false + let rec class_parameters t acc = match t with | Ast.TyCom (_, t1, t2) -> @@ -14628,7 +14570,8 @@ module Struct = let rec type_parameters_and_type_name t acc = match t with | Ast.TyApp (_, t1, t2) -> - type_parameters_and_type_name t1 (type_parameters t2 acc) + type_parameters_and_type_name t1 + (optional_type_parameters t2 acc) | Ast.TyId (_, i) -> ((ident i), acc) | _ -> assert false @@ -14821,6 +14764,7 @@ module Struct = | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i)) | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None)) | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) + | PaMod (loc, m) -> mkpat loc (Ppat_unpack m) | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ as p) -> error (loc_of_patt p) "invalid pattern" and mklabpat = @@ -14871,6 +14815,49 @@ module Struct = let list_of_opt_ctyp ot acc = match ot with | Ast.TyNil _ -> acc | t -> list_of_ctyp t acc + let varify_constructors var_names = + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> Ptyp_var x + | Ptyp_arrow (label, core_type, core_type') -> + Ptyp_arrow (label, (loop core_type), (loop core_type')) + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ((Lident s), []) when List.mem s var_names -> + Ptyp_var ("&" ^ s) + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, (List.map loop lst)) + | Ptyp_object lst -> + Ptyp_object (List.map loop_core_field lst) + | Ptyp_class (longident, lst, lbl_list) -> + Ptyp_class ((longident, (List.map loop lst), lbl_list)) + | Ptyp_alias (core_type, string) -> + Ptyp_alias (((loop core_type), string)) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (((List.map loop_row_field row_field_list), flag, + lbl_lst_option)) + | Ptyp_poly (string_lst, core_type) -> + Ptyp_poly ((string_lst, (loop core_type))) + | Ptyp_package (longident, lst) -> + Ptyp_package + ((longident, + (List.map (fun (n, typ) -> (n, (loop typ))) lst))) + in { (t) with ptyp_desc = desc; } + and loop_core_field t = + let desc = + match t.pfield_desc with + | Pfield ((n, typ)) -> Pfield ((n, (loop typ))) + | Pfield_var -> Pfield_var + in { (t) with pfield_desc = desc; } + and loop_row_field x = + match x with + | Rtag ((label, flag, lst)) -> + Rtag ((label, flag, (List.map loop lst))) + | Rinherit t -> Rinherit (loop t) + in loop + let rec expr = function | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> @@ -15040,7 +15027,7 @@ module Struct = with | Failure _ -> error loc - "Integer literal exceeds the range of representable integers of type int64.1") + "Integer literal exceeds the range of representable integers of type int64") in mkexp loc (Pexp_constant (Const_int64 i64)) | ExNativeInt (loc, s) -> let nati = @@ -15122,9 +15109,12 @@ module Struct = | Ast.ExOpI (loc, i, e) -> mkexp loc (Pexp_open ((long_uident i), (expr e))) | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> - mkexp loc (Pexp_pack ((module_expr me), (package_type pt))) - | Ast.ExPkg (loc, _) -> - error loc "(module_expr : package_type) expected here" + mkexp loc + (Pexp_constraint + (((mkexp loc (Pexp_pack (module_expr me))), + (Some (mktyp loc (Ptyp_package (package_type pt)))), + None))) + | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me)) | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e))) | Ast.ExCom (loc, _, _) -> error loc "expr, expr: not allowed here" @@ -15152,6 +15142,40 @@ module Struct = and binding x acc = match x with | Ast.BiAnd (_, x, y) -> binding x (binding y acc) + | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, bind_name)))), + (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) -> + let rec id_to_string x = + (match x with + | Ast.TyId (_, (Ast.IdLid (_, x))) -> [ x ] + | Ast.TyApp (_, x, y) -> + (id_to_string x) @ (id_to_string y) + | _ -> assert false) in + let vars = id_to_string vs in + let ampersand_vars = List.map (fun x -> "&" ^ x) vars in + let rec merge_quoted_vars lst = + (match lst with + | [ x ] -> x + | x :: y -> Ast.TyApp (_loc, x, (merge_quoted_vars y)) + | [] -> assert false) in + let ty' = varify_constructors vars (ctyp ty) in + let mkexp = mkexp _loc in + let mkpat = mkpat _loc in + let e = + mkexp + (Pexp_constraint ((expr e), (Some (ctyp ty)), None)) in + let rec mk_newtypes x = + (match x with + | [ newtype ] -> mkexp (Pexp_newtype ((newtype, e))) + | newtype :: newtypes -> + mkexp + (Pexp_newtype ((newtype, (mk_newtypes newtypes)))) + | [] -> assert false) in + let pat = + mkpat + (Ppat_constraint + (((mkpat (Ppat_var bind_name)), + (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in + let e = mk_newtypes vars in (pat, e) :: acc | Ast.BiEq (_loc, p, (Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) -> ((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))), @@ -15194,7 +15218,9 @@ module Struct = cl in (c, - (type_decl (List.fold_right type_parameters tl []) cl td)) :: + (type_decl + (List.fold_right optional_type_parameters tl []) cl + td)) :: acc | _ -> assert false and module_type = @@ -15211,6 +15237,8 @@ module Struct = mkmty loc (Pmty_signature (sig_item sl [])) | Ast.MtWit (loc, mt, wc) -> mkmty loc (Pmty_with ((module_type mt), (mkwithc wc []))) + | Ast.MtOf (loc, me) -> + mkmty loc (Pmty_typeof (module_expr me)) | Ast.MtAnt (_, _) -> assert false and sig_item s l = match s with @@ -15291,9 +15319,15 @@ module Struct = mkmod loc (Pmod_constraint ((module_expr me), (module_type mt))) | Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) -> - mkmod loc (Pmod_unpack ((expr e), (package_type pt))) - | Ast.MePkg (loc, _) -> - error loc "(value expr) not supported yet" + mkmod loc + (Pmod_unpack + (mkexp loc + (Pexp_constraint + (((expr e), + (Some + (mktyp loc (Ptyp_package (package_type pt)))), + None))))) + | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e)) | Ast.MeAnt (loc, _) -> error loc "antiquotation in module_expr" and str_item s l = @@ -15327,6 +15361,9 @@ module Struct = (Ast.OSome i)) -> (mkstr loc (Pstr_exn_rebind ((conv_con s), (ident i)))) :: l + | Ast.StExc (loc, + (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), + (Ast.OSome _)) -> error loc "type in exception alias" | StExc (_, _, _) -> assert false | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l | StExt (loc, n, t, sl) -> @@ -15551,14 +15588,12 @@ module Struct = struct class clean_ast = object inherit Ast.map as super - method with_constr = fun wc -> match super#with_constr wc with | Ast.WcAnd (_, (Ast.WcNil _), wc) | Ast.WcAnd (_, wc, (Ast.WcNil _)) -> wc | wc -> wc - method expr = fun e -> match super#expr e with @@ -15569,7 +15604,6 @@ module Struct = Ast.ExSem (_, (Ast.ExNil _), e) | Ast.ExSem (_, e, (Ast.ExNil _)) -> e | e -> e - method patt = fun p -> match super#patt p with @@ -15581,35 +15615,30 @@ module Struct = Ast.PaSem (_, (Ast.PaNil _), p) | Ast.PaSem (_, p, (Ast.PaNil _)) -> p | p -> p - method match_case = fun mc -> match super#match_case mc with | Ast.McOr (_, (Ast.McNil _), mc) | Ast.McOr (_, mc, (Ast.McNil _)) -> mc | mc -> mc - method binding = fun bi -> match super#binding bi with | Ast.BiAnd (_, (Ast.BiNil _), bi) | Ast.BiAnd (_, bi, (Ast.BiNil _)) -> bi | bi -> bi - method rec_binding = fun rb -> match super#rec_binding rb with | Ast.RbSem (_, (Ast.RbNil _), bi) | Ast.RbSem (_, bi, (Ast.RbNil _)) -> bi | bi -> bi - method module_binding = fun mb -> match super#module_binding mb with | Ast.MbAnd (_, (Ast.MbNil _), mb) | Ast.MbAnd (_, mb, (Ast.MbNil _)) -> mb | mb -> mb - method ctyp = fun t -> match super#ctyp t with @@ -15632,7 +15661,6 @@ module Struct = Ast.TySta (_, (Ast.TyNil _), t) | Ast.TySta (_, t, (Ast.TyNil _)) -> t | t -> t - method sig_item = fun sg -> match super#sig_item sg with @@ -15640,7 +15668,6 @@ module Struct = Ast.SgSem (_, sg, (Ast.SgNil _)) -> sg | Ast.SgTyp (loc, (Ast.TyNil _)) -> Ast.SgNil loc | sg -> sg - method str_item = fun st -> match super#str_item st with @@ -15649,41 +15676,35 @@ module Struct = | Ast.StTyp (loc, (Ast.TyNil _)) -> Ast.StNil loc | Ast.StVal (loc, _, (Ast.BiNil _)) -> Ast.StNil loc | st -> st - method module_type = fun mt -> match super#module_type mt with | Ast.MtWit (_, mt, (Ast.WcNil _)) -> mt | mt -> mt - method class_expr = fun ce -> match super#class_expr ce with | Ast.CeAnd (_, (Ast.CeNil _), ce) | Ast.CeAnd (_, ce, (Ast.CeNil _)) -> ce | ce -> ce - method class_type = fun ct -> match super#class_type ct with | Ast.CtAnd (_, (Ast.CtNil _), ct) | Ast.CtAnd (_, ct, (Ast.CtNil _)) -> ct | ct -> ct - method class_sig_item = fun csg -> match super#class_sig_item csg with | Ast.CgSem (_, (Ast.CgNil _), csg) | Ast.CgSem (_, csg, (Ast.CgNil _)) -> csg | csg -> csg - method class_str_item = fun cst -> match super#class_str_item cst with | Ast.CrSem (_, (Ast.CrNil _), cst) | Ast.CrSem (_, cst, (Ast.CrNil _)) -> cst | cst -> cst - end end @@ -15878,10 +15899,7 @@ module Struct = class ['accu] c_fold_pattern_vars : (string -> 'accu -> 'accu) -> 'accu -> - object inherit Ast.fold - val acc : 'accu - method acc : 'accu - + object inherit Ast.fold val acc : 'accu method acc : 'accu end val fold_pattern_vars : @@ -15893,21 +15911,13 @@ module Struct = 'accu -> object ('self_type) inherit Ast.fold - val free : 'accu - val env : S.t - method free : 'accu - method set_env : S.t -> 'self_type - method add_atom : string -> 'self_type - method add_patt : Ast.patt -> 'self_type - method add_binding : Ast.binding -> 'self_type - end val free_vars : S.t -> Ast.expr -> S.t @@ -15922,18 +15932,14 @@ module Struct = class ['accu] c_fold_pattern_vars f init = object inherit Ast.fold as super - val acc = init - method acc : 'accu = acc - method patt = function | Ast.PaId (_, (Ast.IdLid (_, s))) | Ast.PaLab (_, s, (Ast.PaNil _)) | Ast.PaOlb (_, s, (Ast.PaNil _)) -> {< acc = f s acc; >} | p -> super#patt p - end let fold_pattern_vars f p init = @@ -15951,23 +15957,15 @@ module Struct = ?(env_init = S.empty) free_init = object (o) inherit Ast.fold as super - val free = (free_init : 'accu) - val env = (env_init : S.t) - method free = free - method set_env = fun env -> {< env = env; >} - method add_atom = fun s -> {< env = S.add s env; >} - method add_patt = fun p -> {< env = fold_pattern_vars S.add p env; >} - method add_binding = fun bi -> {< env = fold_binding_vars S.add bi env; >} - method expr = function | Ast.ExId (_, (Ast.IdLid (_, s))) | @@ -15985,13 +15983,11 @@ module Struct = | Ast.ExObj (_, p, cst) -> ((o#add_patt p)#class_str_item cst)#set_env env | e -> super#expr e - method match_case = function | Ast.McArr (_, p, e1, e2) -> (((o#add_patt p)#expr e1)#expr e2)#set_env env | m -> super#match_case m - method str_item = function | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s @@ -16000,7 +15996,6 @@ module Struct = | Ast.StVal (_, Ast.ReRecursive, bi) -> (o#add_binding bi)#binding bi | st -> super#str_item st - method class_expr = function | Ast.CeFun (_, p, ce) -> @@ -16014,7 +16009,6 @@ module Struct = | Ast.CeStr (_, p, cst) -> ((o#add_patt p)#class_str_item cst)#set_env env | ce -> super#class_expr ce - method class_str_item = function | (Ast.CrInh (_, _, _, "") as cst) -> @@ -16023,12 +16017,10 @@ module Struct = | Ast.CrVal (_, s, _, _, e) -> (o#expr e)#add_atom s | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s | cst -> super#class_str_item cst - method module_expr = function | Ast.MeStr (_, st) -> (o#str_item st)#set_env env | me -> super#module_expr me - end let free_vars env_init e = @@ -18633,191 +18625,113 @@ module Printers = unit -> object ('a) method interf : formatter -> Ast.sig_item -> unit - method implem : formatter -> Ast.str_item -> unit - method sig_item : formatter -> Ast.sig_item -> unit - method str_item : formatter -> Ast.str_item -> unit - val pipe : bool - val semi : bool - val semisep : sep - + val no_semisep : sep method value_val : string - method value_let : string - method andsep : sep - method anti : formatter -> string -> unit - method class_declaration : formatter -> Ast.class_expr -> unit - method class_expr : formatter -> Ast.class_expr -> unit - method class_sig_item : formatter -> Ast.class_sig_item -> unit - method class_str_item : formatter -> Ast.class_str_item -> unit - method class_type : formatter -> Ast.class_type -> unit - method constrain : formatter -> (Ast.ctyp * Ast.ctyp) -> unit - method ctyp : formatter -> Ast.ctyp -> unit - method ctyp1 : formatter -> Ast.ctyp -> unit - method constructor_type : formatter -> Ast.ctyp -> unit - method dot_expr : formatter -> Ast.expr -> unit - method apply_expr : formatter -> Ast.expr -> unit - method expr : formatter -> Ast.expr -> unit - method expr_list : formatter -> Ast.expr list -> unit - method expr_list_cons : bool -> formatter -> Ast.expr -> unit - method fun_binding : formatter -> fun_binding -> unit - method functor_arg : formatter -> (string * Ast.module_type) -> unit - method functor_args : formatter -> (string * Ast.module_type) list -> unit - method ident : formatter -> Ast.ident -> unit - method numeric : formatter -> string -> string -> unit - method binding : formatter -> Ast.binding -> unit - method record_binding : formatter -> Ast.rec_binding -> unit - method match_case : formatter -> Ast.match_case -> unit - method match_case_aux : formatter -> Ast.match_case -> unit - method mk_expr_list : Ast.expr -> ((Ast.expr list) * (Ast.expr option)) - method mk_patt_list : Ast.patt -> ((Ast.patt list) * (Ast.patt option)) - method simple_module_expr : formatter -> Ast.module_expr -> unit - method module_expr : formatter -> Ast.module_expr -> unit - method module_expr_get_functor_args : (string * Ast.module_type) list -> Ast.module_expr -> (((string * Ast.module_type) list) * Ast. module_expr * (Ast.module_type option)) - method module_rec_binding : formatter -> Ast.module_binding -> unit - method module_type : formatter -> Ast.module_type -> unit - method override_flag : formatter -> Ast.override_flag -> unit - method mutable_flag : formatter -> Ast.mutable_flag -> unit - method direction_flag : formatter -> Ast.direction_flag -> unit - method rec_flag : formatter -> Ast.rec_flag -> unit - method node : formatter -> 'b -> ('b -> Loc.t) -> unit - method patt : formatter -> Ast.patt -> unit - method patt1 : formatter -> Ast.patt -> unit - method patt2 : formatter -> Ast.patt -> unit - method patt3 : formatter -> Ast.patt -> unit - method patt4 : formatter -> Ast.patt -> unit - method patt5 : formatter -> Ast.patt -> unit - method patt_tycon : formatter -> Ast.patt -> unit - method patt_expr_fun_args : formatter -> (fun_binding * Ast.expr) -> unit - method patt_class_expr_fun_args : formatter -> (Ast.patt * Ast.class_expr) -> unit - method print_comments_before : Loc.t -> formatter -> unit - method private_flag : formatter -> Ast.private_flag -> unit - method virtual_flag : formatter -> Ast.virtual_flag -> unit - method quoted_string : formatter -> string -> unit - method raise_match_failure : formatter -> Loc.t -> unit - method reset : 'a - method reset_semi : 'a - method semisep : sep - method set_comments : bool -> 'a - method set_curry_constr : bool -> 'a - method set_loc_and_comments : 'a - method set_semisep : sep -> 'a - method simple_ctyp : formatter -> Ast.ctyp -> unit - method simple_expr : formatter -> Ast.expr -> unit - method simple_patt : formatter -> Ast.patt -> unit - method seq : formatter -> Ast.expr -> unit - method string : formatter -> string -> unit - method sum_type : formatter -> Ast.ctyp -> unit - method type_params : formatter -> Ast.ctyp list -> unit - method class_params : formatter -> Ast.ctyp -> unit - method under_pipe : 'a - method under_semi : 'a - method var : formatter -> string -> unit - method with_constraint : formatter -> Ast.with_constr -> unit - end val with_outfile : @@ -19008,43 +18922,26 @@ module Printers = ?(comments = true) () = object (o) val pipe = false - val semi = false - method under_pipe = {< pipe = true; >} - method under_semi = {< semi = true; >} - method reset_semi = {< semi = false; >} - method reset = {< pipe = false; semi = false; >} - val semisep = (";;" : sep) - + val no_semisep = ("" : sep) val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val var_conversion = false - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "val" - method value_let = "let" - method semisep = semisep - method set_semisep = fun s -> {< semisep = s; >} - method set_comments = fun b -> {< mode = if b then `comments else `no_comments; >} - method set_loc_and_comments = {< mode = `loc_and_comments; >} - method set_curry_constr = fun b -> {< curry_constr = b; >} - method print_comments_before = fun loc f -> match mode with @@ -19059,7 +18956,6 @@ module Printers = (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) (CommentFilter.take_stream comment_filter) | _ -> () - method var = fun f -> function @@ -19087,14 +18983,12 @@ module Printers = (sprintf "Bad token used as an identifier: %s" (Token.to_string tok)))) - method type_params = fun f -> function | [] -> () | [ x ] -> pp f "%a@ " o#ctyp x | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l - method class_params = fun f -> function @@ -19102,44 +18996,37 @@ module Printers = pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 | x -> o#ctyp f x - method override_flag = fun f -> function | Ast.OvOverride -> pp f "!" | Ast.OvNil -> () | Ast.OvAnt s -> o#anti f s - method mutable_flag = fun f -> function | Ast.MuMutable -> pp f "mutable@ " | Ast.MuNil -> () | Ast.MuAnt s -> o#anti f s - method rec_flag = fun f -> function | Ast.ReRecursive -> pp f "rec@ " | Ast.ReNil -> () | Ast.ReAnt s -> o#anti f s - method virtual_flag = fun f -> function | Ast.ViVirtual -> pp f "virtual@ " | Ast.ViNil -> () | Ast.ViAnt s -> o#anti f s - method private_flag = fun f -> function | Ast.PrPrivate -> pp f "private@ " | Ast.PrNil -> () | Ast.PrAnt s -> o#anti f s - method anti = fun f s -> pp f "$%s$" s - method seq = fun f -> function @@ -19147,14 +19034,12 @@ module Printers = pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 | Ast.ExSeq (_, e) -> o#seq f e | e -> o#expr f e - method match_case = fun f -> function | Ast.McNil _loc -> pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc | a -> o#match_case_aux f a - method match_case_aux = fun f -> function @@ -19168,13 +19053,11 @@ module Printers = | Ast.McArr (_, p, w, e) -> pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p o#under_pipe#expr w o#under_pipe#expr e - method fun_binding = fun f -> function | `patt p -> o#simple_patt f p | `newtype i -> pp f "(type %s)" i - method binding = fun f bi -> let () = o#node f bi Ast.loc_of_binding @@ -19199,7 +19082,6 @@ module Printers = pp f "%a @[<0>%a=@]@ %a" o#simple_patt p (list' o#fun_binding "" "@ ") pl o#expr e) | Ast.BiAnt (_, s) -> o#anti f s - method record_binding = fun f bi -> let () = o#node f bi Ast.loc_of_rec_binding @@ -19212,7 +19094,6 @@ module Printers = (o#under_semi#record_binding f b1; o#under_semi#record_binding f b2) | Ast.RbAnt (_, s) -> o#anti f s - method mk_patt_list = function | Ast.PaApp (_, @@ -19222,7 +19103,6 @@ module Printers = let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c) | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None) | p -> ([], (Some p)) - method mk_expr_list = function | Ast.ExApp (_, @@ -19232,7 +19112,6 @@ module Printers = let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c) | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None) | e -> ([], (Some e)) - method expr_list = fun f -> function @@ -19241,7 +19120,6 @@ module Printers = | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el - method expr_list_cons = fun simple f e -> let (el, c) = o#mk_expr_list e @@ -19253,41 +19131,33 @@ module Printers = then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") (list o#under_semi#dot_expr " ::@ ") (el @ [ x ]) - method patt_expr_fun_args = fun f (p, e) -> let (pl, e) = expr_fun_args e in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") (p :: pl) o#expr e - method patt_class_expr_fun_args = fun f (p, ce) -> let (pl, ce) = class_expr_fun_args ce in pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl) o#class_expr ce - method constrain = fun f (t1, t2) -> pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - method sum_type = fun f t -> match Ast.list_of_ctyp t [] with | [] -> () | ts -> pp f "@[| %a@]" (list o#ctyp "@ | ") ts - method string = fun f -> pp f "%s" - method quoted_string = fun f -> pp f "%S" - method numeric = fun f num suff -> if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff - method module_expr_get_functor_args = fun accu -> function @@ -19296,13 +19166,10 @@ module Printers = | Ast.MeTyc (_, me, mt) -> ((List.rev accu), me, (Some mt)) | me -> ((List.rev accu), me, None) - method functor_args = fun f -> list o#functor_arg "@ " f - method functor_arg = fun f (s, mt) -> pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt - method module_rec_binding = fun f -> function @@ -19317,14 +19184,12 @@ module Printers = pp f o#andsep; o#module_rec_binding f mb2) | Ast.MbAnt (_, s) -> o#anti f s - method class_declaration = fun f -> function | Ast.CeTyc (_, ce, ct) -> pp f "%a :@ %a" o#class_expr ce o#class_type ct | ce -> o#class_expr f ce - method raise_match_failure = fun f _loc -> let n = Loc.file_name _loc in @@ -19343,11 +19208,9 @@ module Printers = (Ast.safe_string_escaped n))))), (Ast.ExInt (_loc, (string_of_int l))))), (Ast.ExInt (_loc, (string_of_int c))))))) - method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit = fun f node loc_of_node -> o#print_comments_before (loc_of_node node) f - method ident = fun f i -> let () = o#node f i Ast.loc_of_ident @@ -19359,9 +19222,7 @@ module Printers = pp f "%a@,(%a)" o#ident i1 o#ident i2 | Ast.IdAnt (_, s) -> o#anti f s | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s - method private var_ident = {< var_conversion = true; >}#ident - method expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19471,7 +19332,6 @@ module Printers = "@[@[object @[<2>(%a)@]@ %a@]@ end@]" o#patt p o#class_str_item cst | e -> o#apply_expr f e - method apply_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19479,7 +19339,6 @@ module Printers = match e with | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i | e -> o#dot_expr f e - method dot_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19497,7 +19356,6 @@ module Printers = | Ast.ExSnd (_, e, s) -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s | e -> o#simple_expr f e - method simple_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19571,14 +19429,12 @@ module Printers = Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) | Ast.ExNew (_, _) | Ast.ExObj (_, _, _) -> pp f "(%a)" o#reset#expr e - method direction_flag = fun f b -> match b with | Ast.DiTo -> pp_print_string f "to" | Ast.DiDownto -> pp_print_string f "downto" | Ast.DiAnt s -> o#anti f s - method patt = fun f p -> let () = o#node f p Ast.loc_of_patt @@ -19591,16 +19447,13 @@ module Printers = | Ast.PaSem (_, p1, p2) -> pp f "%a;@ %a" o#patt p1 o#patt p2 | p -> o#patt1 f p - method patt1 = fun f -> function | Ast.PaOrp (_, p1, p2) -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 | p -> o#patt2 f p - method patt2 = fun f p -> o#patt3 f p - method patt3 = fun f -> function @@ -19609,7 +19462,6 @@ module Printers = | Ast.PaCom (_, p1, p2) -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 | p -> o#patt4 f p - method patt4 = fun f -> function @@ -19627,7 +19479,6 @@ module Printers = pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [ x ])) | p -> o#patt5 f p - method patt5 = fun f -> function @@ -19662,7 +19513,6 @@ module Printers = pp f "@[<2>%a@ (%a)@]" o#patt5 a (list o#simple_patt ",@ ") al) | p -> o#simple_patt f p - method simple_patt = fun f p -> let () = o#node f p Ast.loc_of_patt @@ -19672,6 +19522,7 @@ module Printers = | Ast.PaId (_, i) -> o#var_ident f i | Ast.PaAnt (_, s) -> o#anti f s | Ast.PaAny _ -> pp f "_" + | Ast.PaMod (_, m) -> pp f "(module %s)" m | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p | Ast.PaRec (_, p) -> pp f "@[{@ %a@]@ }" o#patt p | Ast.PaStr (_, s) -> pp f "\"%s\"" s @@ -19704,14 +19555,12 @@ module Printers = Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) as p) -> pp f "@[<1>(%a)@]" o#patt p - method patt_tycon = fun f -> function | Ast.PaTyc (_, p, t) -> pp f "%a :@ %a" o#patt p o#ctyp t | p -> o#patt f p - method simple_ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -19720,6 +19569,8 @@ module Printers = | Ast.TyId (_, i) -> o#ident f i | Ast.TyAnt (_, s) -> o#anti f s | Ast.TyAny _ -> pp f "_" + | Ast.TyAnP _ -> pp f "+_" + | Ast.TyAnM _ -> pp f "-_" | Ast.TyLab (_, s, t) -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t | Ast.TyOlb (_, s, t) -> @@ -19754,7 +19605,6 @@ module Printers = pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 | Ast.TyNil _ -> assert false | t -> pp f "@[<1>(%a)@]" o#ctyp t - method ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -19799,7 +19649,6 @@ module Printers = then pp f "@ %a" (list o#constrain "@ ") cl else ()) | t -> o#ctyp1 f t - method ctyp1 = fun f -> function @@ -19816,10 +19665,14 @@ module Printers = in pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") (a :: al) o#ctyp t2 + | Ast.TyTypePol ((_, t1, t2)) -> + let (a, al) = get_ctyp_args t1 [] + in + pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") + (a :: al) o#ctyp t2 | Ast.TyPrv (_, t) -> pp f "@[private@ %a@]" o#simple_ctyp t | t -> o#simple_ctyp f t - method constructor_type = fun f t -> match t with @@ -19830,7 +19683,6 @@ module Printers = o#constructor_type t2 | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t | t -> o#ctyp f t - method sig_item = fun f sg -> let () = o#node f sg Ast.loc_of_sig_item @@ -19887,7 +19739,6 @@ module Printers = o#module_rec_binding mb semisep | Ast.SgDir (_, _, _) -> () | Ast.SgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - method str_item = fun f st -> let () = o#node f st Ast.loc_of_str_item @@ -19954,13 +19805,14 @@ module Printers = | Ast.StDir (_, _, _) -> () | Ast.StAnt (_, s) -> pp f "%a%(%)" o#anti s semisep | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false - method module_type = fun f mt -> let () = o#node f mt Ast.loc_of_module_type in match mt with | Ast.MtNil _ -> assert false + | Ast.MtOf (_, me) -> + pp f "@[<2>module type of@ %a@]" o#module_expr me | Ast.MtId (_, i) -> o#ident f i | Ast.MtAnt (_, s) -> o#anti f s | Ast.MtFun (_, s, mt1, mt2) -> @@ -19972,7 +19824,6 @@ module Printers = | Ast.MtWit (_, mt, wc) -> pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc - method with_constraint = fun f wc -> let () = o#node f wc Ast.loc_of_with_constr @@ -19994,7 +19845,6 @@ module Printers = pp f o#andsep; o#with_constraint f wc2) | Ast.WcAnt (_, s) -> o#anti f s - method module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20007,7 +19857,6 @@ module Printers = "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" o#str_item st o#sig_item sg | _ -> o#simple_module_expr f me - method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20034,7 +19883,6 @@ module Printers = o#module_type mt | Ast.MePkg (_, e) -> pp f "@[<1>(%s %a)@]" o#value_val o#expr e - method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr @@ -20082,7 +19930,6 @@ module Printers = pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 | _ -> assert false - method class_type = fun f ct -> let () = o#node f ct Ast.loc_of_class_type @@ -20119,7 +19966,6 @@ module Printers = | Ast.CtEq (_, ct1, ct2) -> pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 | _ -> assert false - method class_sig_item = fun f csg -> let () = o#node f csg Ast.loc_of_class_sig_item @@ -20135,22 +19981,21 @@ module Printers = o#class_sig_item f csg2) | Ast.CgCtr (_, t1, t2) -> pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 semisep + o#ctyp t2 no_semisep | Ast.CgInh (_, ct) -> pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct - semisep + no_semisep | Ast.CgMth (_, s, pr, t) -> pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag - pr o#var s o#ctyp t semisep + pr o#var s o#ctyp t no_semisep | Ast.CgVir (_, s, pr, t) -> pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t semisep + o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CgVal (_, s, mu, vi, t) -> pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val o#mutable_flag mu o#virtual_flag vi o#var s - o#ctyp t semisep - | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - + o#ctyp t no_semisep + | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep method class_str_item = fun f cst -> let () = o#node f cst Ast.loc_of_class_str_item @@ -20166,45 +20011,43 @@ module Printers = o#class_str_item f cst2) | Ast.CrCtr (_, t1, t2) -> pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 semisep + o#ctyp t2 no_semisep | Ast.CrInh (_, ov, ce, "") -> pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov - o#class_expr ce semisep + o#class_expr ce no_semisep | Ast.CrInh (_, ov, ce, s) -> pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s - semisep + no_semisep | Ast.CrIni (_, e) -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep + pp f "@[<2>initializer@ %a%(%)@]" o#expr e + no_semisep | Ast.CrMth (_, s, ov, pr, e, (Ast.TyNil _)) -> pp f "@[<2>method%a %a%a =@ %a%(%)@]" o#override_flag ov o#private_flag pr o#var s - o#expr e semisep + o#expr e no_semisep | Ast.CrMth (_, s, ov, pr, e, t) -> pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" o#override_flag ov o#private_flag pr o#var s - o#ctyp t o#expr e semisep + o#ctyp t o#expr e no_semisep | Ast.CrVir (_, s, pr, t) -> pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t semisep + o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CrVvr (_, s, mu, t) -> pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" o#value_val - o#mutable_flag mu o#var s o#ctyp t semisep + o#mutable_flag mu o#var s o#ctyp t no_semisep | Ast.CrVal (_, s, ov, mu, e) -> pp f "@[<2>%s%a %a%a =@ %a%(%)@]" o#value_val o#override_flag ov o#mutable_flag mu o#var s - o#expr e semisep - | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - + o#expr e no_semisep + | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep method implem = fun f st -> match st with | Ast.StExp (_, e) -> pp f "@[<0>%a%(%)@]@." o#expr e semisep | st -> pp f "@[%a@]@." o#str_item st - method interf = fun f sg -> pp f "@[%a@]@." o#sig_item sg - end let with_outfile output_file fct arg = @@ -20316,8 +20159,7 @@ module Printers = class printer : ?curry_constr: bool -> ?comments: bool -> - unit -> object ('a) inherit OCaml.Make(Syntax).printer - end + unit -> object ('a) inherit OCaml.Make(Syntax).printer end val with_outfile : string option -> (formatter -> 'a -> unit) -> 'a -> unit @@ -20369,35 +20211,22 @@ module Printers = inherit PP_o.printer ~curry_constr: init_curry_constr ~comments () as super - val! semisep = (";" : sep) - + val! no_semisep = (";" : sep) val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val first_match_case = true - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "value" - method value_let = "value" - method under_pipe = o - method under_semi = o - method reset_semi = o - method reset = o - method private unset_first_match_case = {< first_match_case = false; >} - method private set_first_match_case = {< first_match_case = true; >} - method seq = fun f e -> let rec self right f e = @@ -20421,7 +20250,6 @@ module Printers = | _ -> go_right f e2)) | e -> o#expr f e in self true f e - method var = fun f -> function @@ -20441,14 +20269,12 @@ module Printers = failwith (sprintf "Bad token used as an identifier: %s" (Token.to_string tok))) - method type_params = fun f -> function | [] -> () | [ x ] -> pp f "@ %a" o#ctyp x | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l - method match_case = fun f -> function @@ -20456,7 +20282,6 @@ module Printers = | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m - method match_case_aux = fun f -> function @@ -20475,13 +20300,11 @@ module Printers = in pp f "@[<2>%a@ when@ %a@ ->@ %a@]" o#patt p o#under_pipe#expr w o#under_pipe#expr e - method sum_type = fun f -> function | Ast.TyNil _ -> pp f "[]" | t -> pp f "@[[ %a ]@]" o#ctyp t - method ident = fun f i -> let () = o#node f i Ast.loc_of_ident @@ -20490,7 +20313,6 @@ module Printers = | Ast.IdApp (_, i1, i2) -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 | i -> o#dot_ident f i - method private dot_ident = fun f i -> let () = o#node f i Ast.loc_of_ident @@ -20501,7 +20323,6 @@ module Printers = | Ast.IdAnt (_, s) -> o#anti f s | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s | i -> pp f "(%a)" o#ident i - method patt4 = fun f -> function @@ -20519,7 +20340,6 @@ module Printers = pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x) | p -> super#patt4 f p - method expr_list_cons = fun _ f e -> let (el, c) = o#mk_expr_list e @@ -20529,7 +20349,6 @@ module Printers = | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x - method expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -20548,7 +20367,6 @@ module Printers = pp f "@[fun%a@]" o#match_case a | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]" | e -> super#expr f e - method dot_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -20558,7 +20376,6 @@ module Printers = (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> pp f "@[<2>%a.@,val@]" o#simple_expr e | e -> super#dot_expr f e - method ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -20575,7 +20392,6 @@ module Printers = | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 | t -> super#ctyp f t - method simple_ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -20595,7 +20411,6 @@ module Printers = | Ast.TyLab (_, s, t) -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t | t -> super#simple_ctyp f t - method ctyp1 = fun f -> function @@ -20613,7 +20428,6 @@ module Printers = pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") (a :: al) o#ctyp t2 | t -> super#ctyp1 f t - method constructor_type = fun f t -> match t with @@ -20623,14 +20437,12 @@ module Printers = pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 | t -> o#ctyp f t - method str_item = fun f st -> match st with | Ast.StExp (_, e) -> pp f "@[<2>%a%(%)@]" o#expr e semisep | st -> super#str_item f st - method module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20640,7 +20452,6 @@ module Printers = pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 | me -> super#module_expr f me - method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20648,9 +20459,7 @@ module Printers = match me with | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me | _ -> super#simple_module_expr f me - method implem = fun f st -> pp f "@[%a@]@." o#str_item st - method class_type = fun f ct -> let () = o#node f ct Ast.loc_of_class_type @@ -20671,7 +20480,6 @@ module Printers = pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t | ct -> super#class_type f ct - method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr @@ -20687,9 +20495,8 @@ module Printers = | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) -> pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i - o#ctyp t + o#class_params t | ce -> super#class_expr f ce - end let with_outfile = with_outfile @@ -21418,6 +21225,11 @@ module Register : PreCast.Ast.str_item parser_fun -> PreCast.Ast.sig_item parser_fun -> unit + val current_parser : + unit -> + ((PreCast.Ast.str_item parser_fun) * + (PreCast.Ast.sig_item parser_fun)) + module Parser (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) : sig end @@ -21441,6 +21253,11 @@ module Register : PreCast.Ast.str_item printer_fun -> PreCast.Ast.sig_item printer_fun -> unit + val current_printer : + unit -> + ((PreCast.Ast.str_item printer_fun) * + (PreCast.Ast.sig_item printer_fun)) + module Printer (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) : @@ -21526,12 +21343,16 @@ module Register : let register_parser f g = (str_item_parser := f; sig_item_parser := g) + let current_parser () = ((!str_item_parser), (!sig_item_parser)) + let register_str_item_printer f = str_item_printer := f let register_sig_item_printer f = sig_item_printer := f let register_printer f g = (str_item_printer := f; sig_item_printer := g) + let current_printer () = ((!str_item_printer), (!sig_item_printer)) + module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index 32848f03..acb8afd3 100644 --- a/camlp4/boot/Camlp4Ast.ml +++ b/camlp4/boot/Camlp4Ast.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -108,12 +108,12 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = | Ast.PaLab _ _ p -> is_irrefut_patt p | Ast.PaLaz _ p -> is_irrefut_patt p | Ast.PaId _ _ -> False - | (* here one need to know the arity of constructors *) - Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ | - Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ | - Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ | - Ast.PaAnt _ _ - -> False ]; + | (* here one need to know the arity of constructors *) Ast.PaMod _ _ + -> True + | Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ | + Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ | + Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ | + Ast.PaAnt _ _ -> False ]; value rec is_constructor = fun [ Ast.IdAcc _ _ i -> is_constructor i @@ -471,10 +471,11 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = value meta_loc = meta_loc_expr; module Expr = struct - value meta_string _loc s = Ast.ExStr _loc s; + value meta_string _loc s = + Ast.ExStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.ExInt _loc s; value meta_float _loc s = Ast.ExFlo _loc s; - value meta_char _loc s = Ast.ExChr _loc s; + value meta_char _loc s = Ast.ExChr _loc (String.escaped s); value meta_bool _loc = fun [ False -> Ast.ExId _loc (Ast.IdUid _loc "False") @@ -1042,6 +1043,18 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (Ast.IdUid _loc "TyVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) + | Ast.TyAnM x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAnM"))) + (meta_loc _loc x0) + | Ast.TyAnP x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAnP"))) + (meta_loc _loc x0) | Ast.TyQuM x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc @@ -1066,6 +1079,16 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (Ast.IdUid _loc "TyQuo"))) (meta_loc _loc x0)) (meta_string _loc x1) + | Ast.TyTypePol x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyTypePol"))) + (meta_loc _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) | Ast.TyPol x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc @@ -1910,7 +1933,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (Ast.IdUid _loc "OvOverride")) ] and meta_patt _loc = fun - [ Ast.PaLaz x0 x1 -> + [ Ast.PaMod x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaMod"))) + (meta_loc _loc x0)) + (meta_string _loc x1) + | Ast.PaLaz x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc @@ -3118,6 +3149,18 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (Ast.IdUid _loc "TyVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) + | Ast.TyAnM x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAnM"))) + (meta_loc _loc x0) + | Ast.TyAnP x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAnP"))) + (meta_loc _loc x0) | Ast.TyQuM x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc @@ -3142,6 +3185,16 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (Ast.IdUid _loc "TyQuo"))) (meta_loc _loc x0)) (meta_string _loc x1) + | Ast.TyTypePol x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyTypePol"))) + (meta_loc _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) | Ast.TyPol x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc @@ -3986,7 +4039,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (Ast.IdUid _loc "OvOverride")) ] and meta_patt _loc = fun - [ Ast.PaLaz x0 x1 -> + [ Ast.PaMod x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaMod"))) + (meta_loc _loc x0)) + (meta_string _loc x1) + | Ast.PaLaz x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc @@ -4888,7 +4949,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 | PaLaz _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 ]; + let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 + | PaMod _x _x_i1 -> + let _x = o#loc _x in + let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ]; method override_flag : override_flag -> override_flag = fun [ OvOverride -> OvOverride @@ -4971,7 +5035,20 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MbAnt _x _x_i1 ]; method meta_option : - ! 'a 'a_out. + ! (****************************************************************************) + (* *) + (* OCaml *) + (* *) + (* 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 GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) + (* *) + (****************************************************************************) + 'a 'a_out. ('self_type -> 'a -> 'a_out) -> meta_option 'a -> meta_option 'a_out = fun _f_a -> @@ -5242,6 +5319,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyPol _x _x_i1 _x_i2 + | TyTypePol _x _x_i1 _x_i2 -> + let _x = o#loc _x in + let _x_i1 = o#ctyp _x_i1 in + let _x_i2 = o#ctyp _x_i2 in TyTypePol _x _x_i1 _x_i2 | TyQuo _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuo _x _x_i1 @@ -5251,6 +5332,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = | TyQuM _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuM _x _x_i1 + | TyAnP _x -> let _x = o#loc _x in TyAnP _x + | TyAnM _x -> let _x = o#loc _x in TyAnM _x | TyVrn _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyVrn _x _x_i1 @@ -5672,7 +5755,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o ]; + | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o + | PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method override_flag : override_flag -> 'self_type = fun [ OvOverride -> o @@ -5929,9 +6013,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = | TyPol _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o + | TyTypePol _x _x_i1 _x_i2 -> + let o = o#loc _x in + let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuP _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuM _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o + | TyAnP _x -> let o = o#loc _x in o + | TyAnM _x -> let o = o#loc _x in o | TyVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyRec _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyCol _x _x_i1 _x_i2 -> diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index 786e249c..6cc5466c 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -5,15 +5,15 @@ module R = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -932,6 +932,8 @@ New syntax:\ 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 = @@ -939,6 +941,9 @@ New syntax:\ 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 = @@ -1148,13 +1153,13 @@ New syntax:\ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + (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_UIDENT) _ _ + (fun (mt : 'module_type) _ (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.StMty (_loc, i, mt) : 'str_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; @@ -1520,21 +1525,21 @@ New syntax:\ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk - (fun (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> + (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_UIDENT : 'a_UIDENT Gram.Entry.t)); + (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_UIDENT) _ _ + (fun (mt : 'module_type) _ (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.SgMty (_loc, i, mt) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; @@ -3677,6 +3682,29 @@ New syntax:\ (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) -> @@ -4125,6 +4153,29 @@ New syntax:\ (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) -> @@ -4432,10 +4483,10 @@ New syntax:\ Gram.Slist0 (Gram.Snterm (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t))) ], + (optional_type_parameter : + 'optional_type_parameter Gram.Entry.t))) ], (Gram.Action.mk - (fun (tpl : 'type_parameter list) + (fun (tpl : 'optional_type_parameter list) (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) ()); @@ -4540,6 +4591,76 @@ New syntax:\ '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, @@ -4911,6 +5032,46 @@ New syntax:\ (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 + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ret : 'constructor_arg_list) _ + (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (match Ast.list_of_ctyp ret [] with + | [ c ] -> + Ast.TyCol (_loc, + (Ast.TyId (_loc, + (Ast.IdUid (_loc, s)))), + c) + | _ -> + raise + (Stream.Error + "invalid generalized constructor type") : + 'constructor_declarations)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ret : 'ctyp) _ (t : 'constructor_arg_list) + _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyCol (_loc, + (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), + (Ast.TyArr (_loc, t, ret))) : + 'constructor_declarations)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); @@ -6352,6 +6513,23 @@ New syntax:\ (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)) ], @@ -6836,8 +7014,9 @@ New syntax:\ [ ([ Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + Gram.Snterml + ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), + "top") ], (Gram.Action.mk (fun (e : 'expr) _ (l : 'label) (_loc : Gram.Loc.t) -> @@ -7046,6 +7225,52 @@ New syntax:\ (_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, @@ -8492,10 +8717,9 @@ New syntax:\ (fun (x : 'type_parameter) (_loc : Gram.Loc.t) -> (x : 'more_ctyp)))); ([ Gram.Snterm - (Gram.Entry.obj - (type_kind : 'type_kind Gram.Entry.t)) ], + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk - (fun (x : 'type_kind) (_loc : Gram.Loc.t) -> + (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> (x : 'more_ctyp)))); ([ Gram.Skeyword "`"; Gram.Snterm @@ -9183,15 +9407,15 @@ module Camlp4QuotationCommon = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -9255,7 +9479,6 @@ module Camlp4QuotationCommon = let antiquot_expander = object inherit Ast.map as super - method patt = function | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) -> @@ -9420,7 +9643,6 @@ module Camlp4QuotationCommon = p) | _ -> p) | p -> super#patt p - method expr = function | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) -> @@ -9461,9 +9683,9 @@ module Camlp4QuotationCommon = (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4_import")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Oprint")), - (Ast.IdLid (_loc, "float_repres")))))))), + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Oprint")), + (Ast.IdLid (_loc, "float_repres")))))))), e) | "`str" -> Ast.ExApp (_loc, @@ -9820,7 +10042,6 @@ module Camlp4QuotationCommon = e) | _ -> e) | e -> super#expr e - end let add_quotation name entry mexpr mpatt = @@ -9981,15 +10202,15 @@ module Q = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -10023,15 +10244,15 @@ module Rp = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 1998-2006 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 LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -10966,15 +11187,15 @@ module G = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 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 LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -11813,12 +12034,10 @@ module G = class subst gmod = object inherit Ast.map as super - method ident = function | Ast.IdUid (_, x) when x = gm -> gmod | x -> super#ident x - end let subst_gmod ast gmod = (new subst gmod)#expr ast @@ -11872,13 +12091,11 @@ module G = let wildcarder = object (self) inherit Ast.map as super - method patt = function | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc | Ast.PaAli (_, p, _) -> self#patt p | p -> super#patt p - end let mk_tok _loc p t = @@ -13425,15 +13642,15 @@ module M = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -13566,14 +13783,11 @@ Added statements: in loop class reloc _loc = - object inherit Ast.map as super - method loc = fun _ -> _loc - end + object inherit Ast.map as super method loc = fun _ -> _loc end (* method _Loc_t _ = _loc; *) class subst _loc env = object inherit reloc _loc as super - method expr = function | (Ast.ExId (_, (Ast.IdLid (_, x))) | @@ -13581,7 +13795,6 @@ Added statements: as e) -> (try List.assoc x env with | Not_found -> super#expr e) | e -> super#expr e - method patt = function | (Ast.PaId (_, (Ast.IdLid (_, x))) | @@ -13590,7 +13803,6 @@ Added statements: (try substp _loc [] (List.assoc x env) with | Not_found -> super#patt p) | p -> super#patt p - end let incorrect_number loc l1 l2 = @@ -14448,6 +14660,112 @@ Added statements: (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in i : 'uident)))) ]) ])) + ()); + Gram.extend + (* dirty hack to allow polymorphic variants using the introduced keywords. *) + (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Before "simple")), + [ (None, None, + [ ([ 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.Skeyword "`"; + Gram.srules expr + [ ([ Gram.Skeyword "IN" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "DEFINE" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "ENDIF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "END" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "ELSE" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "THEN" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "IFNDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "IFDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))) ] ], + (Gram.Action.mk + (fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) -> + (Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ])) + ()); + Gram.extend (* idem *) (patt : 'patt Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Before "simple")), + [ (None, None, + [ ([ 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.Skeyword "`"; + Gram.srules patt + [ ([ Gram.Skeyword "ENDIF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "END" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "ELSE" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "THEN" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "IFNDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "IFDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))) ] ], + (Gram.Action.mk + (fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) -> + (Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ])) ())) let _ = @@ -14497,15 +14815,15 @@ module D = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -14690,15 +15008,15 @@ module L = (* -*- camlp4r -*- *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -14989,12 +15307,12 @@ module L = Gram.Skeyword "<-" ], (Gram.Action.mk (fun _ (p : 'patt) (_loc : Gram.Loc.t) - -> (p : 'e__30)))) ]); + -> (p : 'e__32)))) ]); Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk - (fun (e : 'expr) (p : 'e__30) + (fun (e : 'expr) (p : 'e__32) (_loc : Gram.Loc.t) -> (`gen ((p, e)) : 'item)))) ]) ])) ())) @@ -15064,15 +15382,15 @@ module P = struct (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -15087,15 +15405,15 @@ module B = (* camlp4r *) (****************************************************************************) (* *) - (* Objective Caml *) + (* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the Objective *) - (* Caml source tree. *) + (* exception on linking described in LICENSE at the top of the OCaml *) + (* source tree. *) (* *) (****************************************************************************) (* Authors: @@ -15184,7 +15502,7 @@ module B = | (("Parsers" | ""), ("pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo")) - -> load [ pa_r; pa_o; pa_rp ] + -> load [ pa_r; pa_rp ] | (("Parsers" | ""), ("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo")) -> load [ pa_r; pa_o; pa_rp; pa_op ] @@ -15208,7 +15526,7 @@ module B = load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ] | (("Parsers" | ""), "of") -> load - [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m ] + [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ] | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) -> load [ pa_l ] | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) -> diff --git a/camlp4/build/.cvsignore b/camlp4/build/.cvsignore deleted file mode 100644 index 81edfb4d..00000000 --- a/camlp4/build/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -camlp4_config.ml -linenum.mli -linenum.mll -location.ml -location.mli -terminfo.ml -terminfo.mli diff --git a/camlp4/build/.ignore b/camlp4/build/.ignore new file mode 100644 index 00000000..5332d60b --- /dev/null +++ b/camlp4/build/.ignore @@ -0,0 +1,5 @@ +camlp4_config.ml +location.ml +location.mli +terminfo.ml +terminfo.mli diff --git a/camlp4/camlp4prof.ml b/camlp4/camlp4prof.ml index 7e9df17f..ec2ba8c5 100644 --- a/camlp4/camlp4prof.ml +++ b/camlp4/camlp4prof.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + module Debug = struct value mode _ = False; end; value count = diff --git a/camlp4/camlp4prof.mli b/camlp4/camlp4prof.mli index 0703ac03..b7de6450 100644 --- a/camlp4/camlp4prof.mli +++ b/camlp4/camlp4prof.mli @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + value count : string -> unit; value load : in_channel -> list (string * int); diff --git a/camlp4/examples/_tags b/camlp4/examples/_tags index 19b2d701..296772b8 100644 --- a/camlp4/examples/_tags +++ b/camlp4/examples/_tags @@ -1,3 +1,16 @@ +######################################################################### +# # +# 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 GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + true: warn_A, warn_e <{apply_operator,type_quotation,global_handler,expression_closure{,_filter}}.ml> or : camlp4rf, use_camlp4 "lambda_quot.ml": camlp4rf, use_camlp4_full diff --git a/camlp4/examples/apply_operator.ml b/camlp4/examples/apply_operator.ml index 35b17e54..9afbf481 100644 --- a/camlp4/examples/apply_operator.ml +++ b/camlp4/examples/apply_operator.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast; AstFilters.register_str_item_filter (Ast.map_expr diff --git a/camlp4/examples/apply_operator_test.ml b/camlp4/examples/apply_operator_test.ml index 07ca329f..94e7355c 100644 --- a/camlp4/examples/apply_operator_test.ml +++ b/camlp4/examples/apply_operator_test.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + let ( & ) = ();; (* To force it to be inlined. If not it's not well typed. *) fun f g h x -> f& g& h x diff --git a/camlp4/examples/arith.ml b/camlp4/examples/arith.ml index ff7ab4f0..e60c7fb5 100644 --- a/camlp4/examples/arith.ml +++ b/camlp4/examples/arith.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* Please keep me in sync with brion.inria.fr/gallium/index.php/Arithmetic_Example *) open Camlp4.PreCast;; diff --git a/camlp4/examples/debug_extension.ml b/camlp4/examples/debug_extension.ml index 21696e4a..a690044e 100644 --- a/camlp4/examples/debug_extension.ml +++ b/camlp4/examples/debug_extension.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* * No debugging code at all: * $ camlp4o -parser Camlp4DebugParser debug_extension.ml diff --git a/camlp4/examples/ex_str.ml b/camlp4/examples/ex_str.ml index ac9513b9..744cc33c 100644 --- a/camlp4/examples/ex_str.ml +++ b/camlp4/examples/ex_str.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast;; module Caml = Camlp4OCamlParser.Make diff --git a/camlp4/examples/ex_str_test.ml b/camlp4/examples/ex_str_test.ml index 49a696fd..7349c583 100644 --- a/camlp4/examples/ex_str_test.ml +++ b/camlp4/examples/ex_str_test.ml @@ -1 +1,15 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + function <> -> <> diff --git a/camlp4/examples/expression_closure.ml b/camlp4/examples/expression_closure.ml index cfc47454..300d9710 100644 --- a/camlp4/examples/expression_closure.ml +++ b/camlp4/examples/expression_closure.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + #default_quotation "expr"; open Camlp4.PreCast; diff --git a/camlp4/examples/expression_closure_filter.ml b/camlp4/examples/expression_closure_filter.ml index fb1fbe07..dec08b62 100644 --- a/camlp4/examples/expression_closure_filter.ml +++ b/camlp4/examples/expression_closure_filter.ml @@ -1,4 +1,18 @@ (* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + #default_quotation "expr"; open Camlp4.PreCast; diff --git a/camlp4/examples/expression_closure_test.ml b/camlp4/examples/expression_closure_test.ml index 28747ce0..9e4cc536 100644 --- a/camlp4/examples/expression_closure_test.ml +++ b/camlp4/examples/expression_closure_test.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* x and y are free *) close_expr(x y);; diff --git a/camlp4/examples/fancy_lambda_quot.ml b/camlp4/examples/fancy_lambda_quot.ml index be21fa2f..8384dd19 100644 --- a/camlp4/examples/fancy_lambda_quot.ml +++ b/camlp4/examples/fancy_lambda_quot.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* module LambdaSyntax = struct module Loc = Camlp4.PreCast.Loc type 'a antiquotable = diff --git a/camlp4/examples/fancy_lambda_quot_test.ml b/camlp4/examples/fancy_lambda_quot_test.ml index 5ff348c9..9f74deea 100644 --- a/camlp4/examples/fancy_lambda_quot_test.ml +++ b/camlp4/examples/fancy_lambda_quot_test.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Fancy_lambda_quot.LambdaSyntax;; let _loc = Camlp4.PreCast.Loc.ghost;; let rec propagate = function diff --git a/camlp4/examples/free_vars_test.ml b/camlp4/examples/free_vars_test.ml index be01edc1..84d608b4 100644 --- a/camlp4/examples/free_vars_test.ml +++ b/camlp4/examples/free_vars_test.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Format; open Camlp4.PreCast; diff --git a/camlp4/examples/gen_match_case.ml b/camlp4/examples/gen_match_case.ml index c72a1462..cd402d4c 100644 --- a/camlp4/examples/gen_match_case.ml +++ b/camlp4/examples/gen_match_case.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast;; let gen patts exprs = diff --git a/camlp4/examples/gen_type_N.ml b/camlp4/examples/gen_type_N.ml index 276f682b..361f7473 100644 --- a/camlp4/examples/gen_type_N.ml +++ b/camlp4/examples/gen_type_N.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast;; let data_constructor_arguments _loc n t = diff --git a/camlp4/examples/gettext_test.ml b/camlp4/examples/gettext_test.ml index 27f6ceed..11d1f146 100644 --- a/camlp4/examples/gettext_test.ml +++ b/camlp4/examples/gettext_test.ml @@ -1 +1,15 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + f "test", f "foo", "bar" diff --git a/camlp4/examples/global_handler.ml b/camlp4/examples/global_handler.ml index e2da5287..08957fb8 100644 --- a/camlp4/examples/global_handler.ml +++ b/camlp4/examples/global_handler.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast; value ghost = Loc.ghost; diff --git a/camlp4/examples/global_handler_test.ml b/camlp4/examples/global_handler_test.ml index 882af494..9c3e98ca 100644 --- a/camlp4/examples/global_handler_test.ml +++ b/camlp4/examples/global_handler_test.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Format;; let f1 x = printf "f1 %d@." x;; let f2 x = printf "f2 %f@." x;; diff --git a/camlp4/examples/lambda_parser.ml b/camlp4/examples/lambda_parser.ml index 9c709767..82ab3b8b 100644 --- a/camlp4/examples/lambda_parser.ml +++ b/camlp4/examples/lambda_parser.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *) type term = diff --git a/camlp4/examples/lambda_quot.ml b/camlp4/examples/lambda_quot.ml index 654511af..cf6485ab 100644 --- a/camlp4/examples/lambda_quot.ml +++ b/camlp4/examples/lambda_quot.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast; module CamlSyntax = Camlp4OCamlParser.Make (Camlp4OCamlRevisedParser.Make Syntax); diff --git a/camlp4/examples/lambda_quot_expr.ml b/camlp4/examples/lambda_quot_expr.ml index 98922123..d3eb22fe 100644 --- a/camlp4/examples/lambda_quot_expr.ml +++ b/camlp4/examples/lambda_quot_expr.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *) open Camlp4.PreCast;; diff --git a/camlp4/examples/lambda_quot_patt.ml b/camlp4/examples/lambda_quot_patt.ml index e6732dd3..044007b5 100644 --- a/camlp4/examples/lambda_quot_patt.ml +++ b/camlp4/examples/lambda_quot_patt.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *) open Camlp4.PreCast;; diff --git a/camlp4/examples/lambda_test.ml b/camlp4/examples/lambda_test.ml index e2603259..f56451fc 100644 --- a/camlp4/examples/lambda_test.ml +++ b/camlp4/examples/lambda_test.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + let id = << fun x -> x >> (* Imported and traduced from CCT *) let zero = << fun s -> fun z -> z >> diff --git a/camlp4/examples/macros.ml b/camlp4/examples/macros.ml index fe7b7392..3ad5687f 100644 --- a/camlp4/examples/macros.ml +++ b/camlp4/examples/macros.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast;; let foldr_funs = ref [];; let foldl_funs = ref [];; diff --git a/camlp4/examples/parse_files.ml b/camlp4/examples/parse_files.ml index 0df49c18..46cf8420 100644 --- a/camlp4/examples/parse_files.ml +++ b/camlp4/examples/parse_files.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast;; module Caml = diff --git a/camlp4/examples/syb_fold.ml b/camlp4/examples/syb_fold.ml index 3441c6b6..f5abc698 100644 --- a/camlp4/examples/syb_fold.ml +++ b/camlp4/examples/syb_fold.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + type variable = string and term = | Var of variable diff --git a/camlp4/examples/syb_map.ml b/camlp4/examples/syb_map.ml index 8ef923f3..91856305 100644 --- a/camlp4/examples/syb_map.ml +++ b/camlp4/examples/syb_map.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + type variable = string and term = | Var of variable diff --git a/camlp4/examples/test_macros.ml b/camlp4/examples/test_macros.ml index 1e1b172b..955a7c21 100644 --- a/camlp4/examples/test_macros.ml +++ b/camlp4/examples/test_macros.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + (* DEFINE F(x, y, z) = x + y * z;; *) (* F(F(1, 2, 3), 4, 5);; *) diff --git a/camlp4/examples/test_type_quotation.ml b/camlp4/examples/test_type_quotation.ml index 772dfcfc..088924c8 100644 --- a/camlp4/examples/test_type_quotation.ml +++ b/camlp4/examples/test_type_quotation.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + type t1 = <:power< 6 | int >> type t2 = <:power< 3 | int -> int >> -> int type t3 = <:power< 3 | int -> <:power< 2 | int >> >> -> int diff --git a/camlp4/examples/type_quotation.ml b/camlp4/examples/type_quotation.ml index 5dae046f..5c569a94 100644 --- a/camlp4/examples/type_quotation.ml +++ b/camlp4/examples/type_quotation.ml @@ -1,3 +1,17 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) +(* *) +(****************************************************************************) + open Camlp4.PreCast; value rec mk_tuple _loc t n = diff --git a/camlp4/man/.cvsignore b/camlp4/man/.cvsignore deleted file mode 100644 index 2dc933cb..00000000 --- a/camlp4/man/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -camlp4.1 -camlp4.help diff --git a/camlp4/man/.ignore b/camlp4/man/.ignore new file mode 100644 index 00000000..2dc933cb --- /dev/null +++ b/camlp4/man/.ignore @@ -0,0 +1,2 @@ +camlp4.1 +camlp4.help diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile index 381bdcc5..64b3f970 100644 --- a/camlp4/man/Makefile +++ b/camlp4/man/Makefile @@ -1,4 +1,15 @@ - +######################################################################### +# # +# OCaml # +# # +# Daniel de Rauglaudre, 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. # +# # +######################################################################### include ../config/Makefile.cnf diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl index ff8c6504..664ca9f7 100644 --- a/camlp4/man/camlp4.1.tpl +++ b/camlp4/man/camlp4.1.tpl @@ -1,3 +1,18 @@ +.\"*********************************************************************** +.\"* * +.\"* OCaml * +.\"* * +.\"* Daniel de Rauglaudre, 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. * +.\"* * +.\"*********************************************************************** +.\" +.\" $Id$ +.\" .TH CAMLP4 1 "" "INRIA" .SH NAME camlp4 - Pre-Precessor-Pretty-Printer for OCaml diff --git a/camlp4/mkcamlp4.ml b/camlp4/mkcamlp4.ml index 8c911b12..180b17ef 100644 --- a/camlp4/mkcamlp4.ml +++ b/camlp4/mkcamlp4.ml @@ -1,14 +1,14 @@ (****************************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* 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 GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the Objective *) -(* Caml source tree. *) +(* exception on linking described in LICENSE at the top of the OCaml *) +(* source tree. *) (* *) (****************************************************************************) diff --git a/camlp4/unmaintained/Makefile b/camlp4/unmaintained/Makefile index b6db0753..ff79e336 100644 --- a/camlp4/unmaintained/Makefile +++ b/camlp4/unmaintained/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # diff --git a/camlp4/unmaintained/compile/.cvsignore b/camlp4/unmaintained/compile/.cvsignore deleted file mode 100644 index 47817cce..00000000 --- a/camlp4/unmaintained/compile/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.fast -*.fast.opt -o_fast.ml -pa_o_fast.ml diff --git a/camlp4/unmaintained/compile/.ignore b/camlp4/unmaintained/compile/.ignore new file mode 100644 index 00000000..47817cce --- /dev/null +++ b/camlp4/unmaintained/compile/.ignore @@ -0,0 +1,4 @@ +*.fast +*.fast.opt +o_fast.ml +pa_o_fast.ml diff --git a/camlp4/unmaintained/etc/.cvsignore b/camlp4/unmaintained/etc/.cvsignore deleted file mode 100644 index 50d8a8ea..00000000 --- a/camlp4/unmaintained/etc/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -*.cm[oia] -camlp4o -camlp4sch -camlp4o.opt -version.sh -mkcamlp4.sh -mkcamlp4.mpw diff --git a/camlp4/unmaintained/etc/.ignore b/camlp4/unmaintained/etc/.ignore new file mode 100644 index 00000000..709f85c4 --- /dev/null +++ b/camlp4/unmaintained/etc/.ignore @@ -0,0 +1,5 @@ +camlp4o +camlp4sch +camlp4o.opt +version.sh +mkcamlp4.sh diff --git a/camlp4/unmaintained/etc/pa_oop.ml b/camlp4/unmaintained/etc/pa_oop.ml index bb5684ba..62302e39 100644 --- a/camlp4/unmaintained/etc/pa_oop.ml +++ b/camlp4/unmaintained/etc/pa_oop.ml @@ -107,7 +107,7 @@ value rec cstream gloc = <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] ; -(* Syntax extensions in Ocaml grammar *) +(* Syntax extensions in OCaml grammar *) EXTEND diff --git a/camlp4/unmaintained/extfold/README b/camlp4/unmaintained/extfold/README index 2a09ff09..dce3da11 100644 --- a/camlp4/unmaintained/extfold/README +++ b/camlp4/unmaintained/extfold/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/camlp4/unmaintained/format/Makefile b/camlp4/unmaintained/format/Makefile index c3887209..1211a799 100644 --- a/camlp4/unmaintained/format/Makefile +++ b/camlp4/unmaintained/format/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # diff --git a/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README index 809d42f2..830402b6 100644 --- a/camlp4/unmaintained/format/README +++ b/camlp4/unmaintained/format/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/camlp4/unmaintained/lefteval/Makefile b/camlp4/unmaintained/lefteval/Makefile index 7e5cdd02..5d47776c 100644 --- a/camlp4/unmaintained/lefteval/Makefile +++ b/camlp4/unmaintained/lefteval/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # diff --git a/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README index 809d42f2..830402b6 100644 --- a/camlp4/unmaintained/lefteval/README +++ b/camlp4/unmaintained/lefteval/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/camlp4/unmaintained/ocamllex/Makefile b/camlp4/unmaintained/ocamllex/Makefile index b232023e..1407c40a 100644 --- a/camlp4/unmaintained/ocamllex/Makefile +++ b/camlp4/unmaintained/ocamllex/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # diff --git a/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README index 809d42f2..830402b6 100644 --- a/camlp4/unmaintained/ocamllex/README +++ b/camlp4/unmaintained/ocamllex/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/camlp4/unmaintained/ocpp/.cvsignore b/camlp4/unmaintained/ocpp/.cvsignore deleted file mode 100644 index baef26c6..00000000 --- a/camlp4/unmaintained/ocpp/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -ocpp -crc.ml diff --git a/camlp4/unmaintained/ocpp/.ignore b/camlp4/unmaintained/ocpp/.ignore new file mode 100644 index 00000000..f9922671 --- /dev/null +++ b/camlp4/unmaintained/ocpp/.ignore @@ -0,0 +1,2 @@ +ocpp +crc.ml diff --git a/camlp4/unmaintained/odyl/.cvsignore b/camlp4/unmaintained/odyl/.cvsignore deleted file mode 100644 index 8ae0ebb0..00000000 --- a/camlp4/unmaintained/odyl/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.cm[oia] -odyl -*.lib -odyl_config.ml diff --git a/camlp4/unmaintained/odyl/.ignore b/camlp4/unmaintained/odyl/.ignore new file mode 100644 index 00000000..c270c791 --- /dev/null +++ b/camlp4/unmaintained/odyl/.ignore @@ -0,0 +1,3 @@ +odyl +*.lib +odyl_config.ml diff --git a/camlp4/unmaintained/olabl/Makefile b/camlp4/unmaintained/olabl/Makefile index f928d458..2d9eb690 100644 --- a/camlp4/unmaintained/olabl/Makefile +++ b/camlp4/unmaintained/olabl/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # diff --git a/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README index 809d42f2..830402b6 100644 --- a/camlp4/unmaintained/olabl/README +++ b/camlp4/unmaintained/olabl/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/camlp4/unmaintained/olabl/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml index 285902a1..da70a675 100644 --- a/camlp4/unmaintained/olabl/pa_olabl.ml +++ b/camlp4/unmaintained/olabl/pa_olabl.ml @@ -1964,7 +1964,7 @@ value rec cstream gloc = else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] ; -(* Syntax extensions in Ocaml grammar *) +(* Syntax extensions in OCaml grammar *) EXTEND GLOBAL: expr; diff --git a/camlp4/unmaintained/scheme/Makefile b/camlp4/unmaintained/scheme/Makefile index dd234bf9..4034629f 100644 --- a/camlp4/unmaintained/scheme/Makefile +++ b/camlp4/unmaintained/scheme/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # @@ -38,7 +39,7 @@ opt: all bootstrap: camlp4sch$(EXE) save ./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \ | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \ - -e 's/$$Id$/File generated by pretty print; do not edit!/' > pa_scheme.ml + -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml @if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \ echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \ else \ @@ -77,7 +78,7 @@ pr_schemep.cmo: pr_schp_main.cmo .ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< diff --git a/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README index 809d42f2..830402b6 100644 --- a/camlp4/unmaintained/scheme/README +++ b/camlp4/unmaintained/scheme/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/camlp4/unmaintained/sml/Makefile b/camlp4/unmaintained/sml/Makefile index ea3980be..80b17242 100644 --- a/camlp4/unmaintained/sml/Makefile +++ b/camlp4/unmaintained/sml/Makefile @@ -1,12 +1,13 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # diff --git a/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README index 809d42f2..830402b6 100644 --- a/camlp4/unmaintained/sml/README +++ b/camlp4/unmaintained/sml/README @@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both +This package is distributed under the same license as the OCaml +Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny diff --git a/config/.cvsignore b/config/.cvsignore deleted file mode 100644 index 9fc1c014..00000000 --- a/config/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -m.h -s.h -Makefile -config.sh diff --git a/config/.ignore b/config/.ignore new file mode 100644 index 00000000..9fc1c014 --- /dev/null +++ b/config/.ignore @@ -0,0 +1,4 @@ +m.h +s.h +Makefile +config.sh diff --git a/config/Makefile-templ b/config/Makefile-templ index dd65452a..626d30e8 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -46,19 +46,15 @@ SHARPBANGSCRIPTS=true #BYTECC=cc ### Additional compile-time options for $(BYTECC). -# If using gcc on Intel 386 or Motorola 68k: +# If using gcc on Intel x86: # (the -fno-defer-pop option circumvents a bug in certain versions of gcc) #BYTECCCOMPOPTS=-fno-defer-pop -Wall -# If using gcc and being superstitious: +# If using gcc and being cautious: #BYTECCCOMPOPTS=-Wall -# Under NextStep: -#BYTECCCOMPOPTS=-U__GNUC__ -fno-defer-pop -Wall # Otherwise: #BYTECCCOMPOPTS= ### Additional link-time options for $(BYTECC) -### If using GCC on a Dec Alpha under OSF1: -#BYTECCLINKOPTS=-Wl,-T,12000000 -Wl,-D,14000000 # To support dynamic loading of shared libraries (they need to look at # our own symbols): #BYTECCLINKOPTS=-Wl,-E @@ -90,6 +86,9 @@ RANLIBCMD=ranlib #RANLIB=ar rs #RANLIBCMD= +### How to invoke ar +#ARCMD=ar + ### Shared library support # Extension for shared libraries: so if supported, a if not supported #SO=so @@ -111,23 +110,15 @@ RANLIBCMD=ranlib ### Name of architecture for the native-code compiler ### Currently supported: ### -### alpha Digital/Compaq Alpha machines under DUnix/Tru64 or Linux ### i386 Intel Pentium PCs under Linux, *BSD*, NextStep ### sparc Sun Sparcstation under SunOS 4.1 or Solaris 2 -### mips SGI machines under IRIX -### hppa HP 9000/700 under HPUX and Linux ### power Macintosh under Mac OS X and Linux -### ia64 Intel Itanium/IA64 under Linux ### arm ARM under Linux ### ### Set ARCH=none if your machine is not supported -#ARCH=alpha #ARCH=i386 #ARCH=sparc -#ARCH=mips -#ARCH=hppa #ARCH=power -#ARCH=ia64 #ARCH=arm #ARCH=none @@ -144,37 +135,18 @@ RANLIBCMD=ranlib #MODEL=default ### Name of operating system family for the native-code compiler. -### If ARCH=sparc: choose between -### SYSTEM=sunos SunOS 4.1 -### SYSTEM=solaris Solaris 2 -### -### If ARCH=i386: choose between -### SYSTEM=linux_aout Linux with a.out binaries -### SYSTEM=linux_elf Linux with ELF binaries -### SYSTEM=bsd FreeBSD, probably works for NetBSD also -### SYSTEM=nextstep NextStep -### -### For other architectures: set SYSTEM=unknown -### -#SYSTEM=sunos #SYSTEM=solaris #SYSTEM=linux #SYSTEM=linux_elf #SYSTEM=bsd -#SYSTEM=nextstep #SYSTEM=unknown ### Which C compiler to use for the native-code compiler. -### cc is better than gcc on the Mips and Alpha. #NATIVECC=cc #NATIVECC=gcc ### Additional compile-time options for $(NATIVECC). -# For cc on the Alpha: -#NATIVECCCOMPOPTS=-std1 -# For cc on the Mips: -#NATIVECCCOMPOPTS=-std -# For gcc if superstitious: +# For gcc if cautious: #NATIVECCCOMPOPTS=-Wall ### Additional link-time options for $(NATIVECC) @@ -185,29 +157,21 @@ RANLIBCMD=ranlib #NATIVECCRPATH=-Wl,-rpath ### Command and flags to use for assembling ocamlopt-generated code -# For the Alpha or the Mips: -#AS=as -O2 -# For the PowerPC: -#AS=as -u -m ppc -w -# Otherwise: -#AS=as +#ASM=as ### Command and flags to use for assembling .S files (often with preprocessing) # If gcc is available: #ASPP=gcc -c -# On SunOS and Solaris: +# On Solaris: #ASPP=as -P ### Extra flags to use for assembling .S files in profiling mode -# On Digital Unix: -#ASPPPROFFLAGS=-pg -DPROFILING -# Otherwise: #ASPPPROFFLAGS=-DPROFILING ### Whether profiling with gprof is supported -# If yes: (x86/Linux, Alpha/Digital Unix, Sparc/Solaris): +# If yes: (e.g. x86/Linux, Sparc/Solaris): #PROFILING=prof -# If no: (all others) +# If no: #PROFILING=noprof ### Option to give to the C compiler for profiling @@ -238,8 +202,6 @@ OTHERLIBRARIES=unix str num threads graph dynlink labltk bigarray # generic (portable C, works everywhere) # ia32 (Intel x86) # amd64 (AMD Opteron, Athlon64) -# alpha -# mips # ppc (Power PC) # sparc # If you don't know, leave BNG_ARCH=generic, which selects a portable @@ -268,13 +230,6 @@ BNG_ASM_LEVEL=1 # For SunOS with OpenLook: #X11_LINK=-L$(X11_LIB) -lX11 -### -I options for finding the include file ndbm.h -# Needed for the "dbm" package -# Usually: -#DBM_INCLUDES= -# For recent Linux systems: -#DBM_INCLUDES=-I/usr/include/gdbm - ### Preprocessor options for finding tcl.h and tk.h # Needed for the "labltk" package # Required only if not in the standard include path. diff --git a/config/Makefile.mingw b/config/Makefile.mingw index f2e408cc..ddbc6287 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -19,6 +19,9 @@ PREFIX=C:/ocamlmgw +### Remove this to disable compiling camlp4 +CAMLP4=camlp4 + ### Where to install the binaries BINDIR=$(PREFIX)/bin @@ -37,6 +40,10 @@ MANDIR=$(PREFIX)/man ########## Toolchain and OS dependencies TOOLCHAIN=mingw + +### Toolchain prefix +TOOLPREF=i686-w64-mingw32- + CCOMPTYPE=cc O=o A=a @@ -61,10 +68,11 @@ SHAREDCCCOMPOPTS= MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= -ASM=as +ASM=$(TOOLPREF)as ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof +RUNTIMED=noruntimed DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= @@ -72,11 +80,13 @@ SYSTHREAD_SUPPORT=true EXTRALIBS= NATDYNLINK=true CMXS=cmxs +RUNTIMED=noruntimed +ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. -BYTECC=gcc -mno-cygwin +BYTECC=$(TOOLPREF)gcc ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused @@ -95,7 +105,7 @@ NATIVECCLIBS=-lws2_32 CPP=$(BYTECC) -E ### Flexlink -FLEXLINK=flexlink -chain mingw +FLEXLINK=flexlink -chain mingw -stack 16777216 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) @@ -103,16 +113,19 @@ MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library -MKLIB=rm -f $(1); ar rcs $(1) $(2) -#ml let mklib out files opts = Printf.sprintf "rm -f %s && ar rcs %s %s %s" out opts out files;; +MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1) +#ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;; ### Canonicalize the name of a system library SYSLIB=-l$(1) #ml let syslib x = "-l"^x;; ### The ranlib command -RANLIB=ranlib -RANLIBCMD=ranlib +RANLIB=$(TOOLPREF)ranlib +RANLIBCMD=$(TOOLPREF)ranlib + +### The ar command +ARCMD=$(TOOLPREF)ar ############# Configuration for the native-code compiler @@ -135,7 +148,7 @@ NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' +PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' ############# Configuration for the contributed libraries diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 new file mode 100644 index 00000000..86dd90a0 --- /dev/null +++ b/config/Makefile.mingw64 @@ -0,0 +1,164 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + +# $Id: Makefile.mingw 11319 2011-12-16 17:02:48Z xleroy $ + +# Configuration for Windows, Mingw compiler + +######### General configuration + +PREFIX=C:/ocamlmgw64 + +### Where to install the binaries +BINDIR=$(PREFIX)/bin + +### Where to install the standard library +LIBDIR=$(PREFIX)/lib + +### Where to install the stub DLLs +STUBLIBDIR=$(LIBDIR)/stublibs + +### Where to install the info files +DISTRIB=$(PREFIX) + +### Where to install the man pages +MANDIR=$(PREFIX)/man + +########## Toolchain and OS dependencies + +TOOLCHAIN=mingw + +### Toolchain prefix +TOOLPREF=x86_64-w64-mingw32- + +CCOMPTYPE=cc +O=o +A=a +S=s +SO=s.o +DO=d.o +EXE=.exe +EXT_DLL=.dll +EXT_OBJ=.$(O) +EXT_LIB=.$(A) +EXT_ASM=.$(S) +MANEXT=1 +SHARPBANGSCRIPTS=false +PTHREAD_LINK= +X11_INCLUDES= +X11_LINK= +DBM_INCLUDES= +DBM_LINK= +BYTECCRPATH= +SUPPORTS_SHARED_LIBRARIES=true +SHAREDCCCOMPOPTS= +MKSHAREDLIBRPATH= +NATIVECCPROFOPTS= +NATIVECCRPATH= +ASM=$(TOOLPREF)as +ASPP=gcc +ASPPPROFFLAGS= +PROFILING=noprof +RUNTIMED=noruntimed +DYNLINKOPTS= +DEBUGGER=ocamldebugger +CC_PROFILE= +SYSTHREAD_SUPPORT=true +EXTRALIBS= +NATDYNLINK=true +CMXS=cmxs +RUNTIMED=noruntimed + +########## Configuration for the bytecode compiler + +### Which C compiler to use for the bytecode interpreter. +BYTECC=$(TOOLPREF)gcc + +### Additional compile-time options for $(BYTECC). (For static linking.) +BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused + +### Additional link-time options for $(BYTECC). (For static linking.) +BYTECCLINKOPTS= + +### Additional compile-time options for $(BYTECC). (For building a DLL.) +DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL + +### Libraries needed +BYTECCLIBS=-lws2_32 +NATIVECCLIBS=-lws2_32 + +### How to invoke the C preprocessor +CPP=$(BYTECC) -E + +### Flexlink +FLEXLINK=flexlink -chain mingw64 -stack 33554432 +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll + +### How to build a static library +MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1) +#ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;; + +### Canonicalize the name of a system library +SYSLIB=-l$(1) +#ml let syslib x = "-l"^x;; + +### The ranlib command +RANLIB=$(TOOLPREF)ranlib +RANLIBCMD=$(TOOLPREF)ranlib + +### The ar command +ARCMD=$(TOOLPREF)ar + +############# Configuration for the native-code compiler + +### Name of architecture for the native-code compiler +ARCH=amd64 + +### Name of architecture model for the native-code compiler. +MODEL=default + +### Name of operating system family for the native-code compiler. +SYSTEM=mingw64 + +### Which C compiler to use for the native-code compiler. +NATIVECC=$(BYTECC) + +### Additional compile-time options for $(NATIVECC). +NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused + +### Additional link-time options for $(NATIVECC) +NATIVECCLINKOPTS= + +### Build partially-linked object file +PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' + +############# Configuration for the contributed libraries + +OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads + +### Name of the target architecture for the "num" library +BNG_ARCH=amd64 +BNG_ASM_LEVEL=1 + +### Configuration for LablTk (not supported) +TK_DEFS= +TK_LINK= + +############# Aliases for common commands + +MAKEREC=$(MAKE) -f Makefile.nt +MAKECMD=$(MAKE) diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 8f0a50ce..ff96ea27 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -71,6 +71,7 @@ SYSTHREAD_SUPPORT=true EXTRALIBS= CMXS=cmxs NATDYNLINK=true +RUNTIMED=noruntimed ########## Configuration for the bytecode compiler @@ -94,11 +95,11 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib CPP=cl /nologo /EP ### Flexlink -FLEXLINK=flexlink -merge-manifest +FLEXLINK=flexlink -merge-manifest -stack 16777216 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) -MKEXE=$(FLEXLINK) -exe -link /STACK:16777216 +MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library @@ -114,6 +115,9 @@ SYSLIB=$(1).lib RANLIB=echo RANLIBCMD= +### The ar command +ARCMD= + ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler @@ -137,6 +141,13 @@ NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' +############# Configuration for camlp4 + +# This variable controls whether camlp4 will be built. +# If it is set to camlp4, then it will be built. +# If it is set to the empty string, then it will not be built. +CAMLP4=camlp4 + ############# Configuration for the contributed libraries OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index e91b26f7..b6c2c6bc 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -71,6 +71,7 @@ CC_PROFILE= SYSTHREAD_SUPPORT=true CMXS=cmxs NATDYNLINK=true +RUNTIMED=noruntimed ########## Configuration for the bytecode compiler @@ -99,11 +100,11 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) CPP=cl /nologo /EP ### Flexlink -FLEXLINK=flexlink -x64 -merge-manifest +FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) -MKEXE=$(FLEXLINK) -exe -link /STACK:33554432 +MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library @@ -119,6 +120,9 @@ SYSLIB=$(1).lib RANLIB=echo RANLIBCMD= +### The ar command +ARCMD= + ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler diff --git a/config/auto-aux/.cvsignore b/config/auto-aux/.cvsignore deleted file mode 100644 index cb1ca8a9..00000000 --- a/config/auto-aux/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -camlp4_config.ml diff --git a/config/auto-aux/.ignore b/config/auto-aux/.ignore new file mode 100644 index 00000000..cb1ca8a9 --- /dev/null +++ b/config/auto-aux/.ignore @@ -0,0 +1 @@ +camlp4_config.ml diff --git a/config/auto-aux/align.c b/config/auto-aux/align.c index 0bedf77a..a04684b4 100644 --- a/config/auto-aux/align.c +++ b/config/auto-aux/align.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/ansi.c b/config/auto-aux/ansi.c index f1a416b8..01d46252 100644 --- a/config/auto-aux/ansi.c +++ b/config/auto-aux/ansi.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/async_io.c b/config/auto-aux/async_io.c index 2b5faa2d..2ce3da72 100644 --- a/config/auto-aux/async_io.c +++ b/config/auto-aux/async_io.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/bytecopy.c b/config/auto-aux/bytecopy.c index 923b444e..2006147f 100644 --- a/config/auto-aux/bytecopy.c +++ b/config/auto-aux/bytecopy.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/cfi.S b/config/auto-aux/cfi.S new file mode 100644 index 00000000..e055423a --- /dev/null +++ b/config/auto-aux/cfi.S @@ -0,0 +1,3 @@ +.cfi_startproc +.cfi_adjust_cfa_offset 8 +.cfi_endproc diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c index c2520381..91d4194c 100644 --- a/config/auto-aux/dblalign.c +++ b/config/auto-aux/dblalign.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c index 8f69dabf..d59bf31c 100644 --- a/config/auto-aux/divmod.c +++ b/config/auto-aux/divmod.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/elf.c b/config/auto-aux/elf.c index 026c4838..27be98d6 100644 --- a/config/auto-aux/elf.c +++ b/config/auto-aux/elf.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/endian.c b/config/auto-aux/endian.c index def617f0..b019eb1c 100644 --- a/config/auto-aux/endian.c +++ b/config/auto-aux/endian.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/expm1.c b/config/auto-aux/expm1.c index be41d023..db4413b9 100644 --- a/config/auto-aux/expm1.c +++ b/config/auto-aux/expm1.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/getgroups.c b/config/auto-aux/getgroups.c index 1ed8a1fb..b69b0be4 100644 --- a/config/auto-aux/getgroups.c +++ b/config/auto-aux/getgroups.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/gethostbyaddr.c b/config/auto-aux/gethostbyaddr.c index c5dd1297..f6d36a7f 100644 --- a/config/auto-aux/gethostbyaddr.c +++ b/config/auto-aux/gethostbyaddr.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/gethostbyname.c b/config/auto-aux/gethostbyname.c index 043b9d33..96a39438 100644 --- a/config/auto-aux/gethostbyname.c +++ b/config/auto-aux/gethostbyname.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot index 5014b903..53d57866 100755 --- a/config/auto-aux/hasgot +++ b/config/auto-aux/hasgot @@ -1,5 +1,18 @@ #!/bin/sh +######################################################################### +# # +# 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 GNU Library General Public License, with # +# the special exception on linking described in file ../../LICENSE. # +# # +######################################################################### + opts="" libs="$cclibs" args=$* diff --git a/config/auto-aux/hasgot2 b/config/auto-aux/hasgot2 new file mode 100644 index 00000000..0e9cef9b --- /dev/null +++ b/config/auto-aux/hasgot2 @@ -0,0 +1,42 @@ +#!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, 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 GNU Library General Public License, with # +# the special exception on linking described in file ../../LICENSE. # +# # +######################################################################### + +opts="" +libs="$cclibs" +args=$* +rm -f hasgot.c +var="x" +while : ; do + case "$1" in + -i) echo "#include <$2>" >> hasgot.c; shift;; + -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; + -l*|-L*|-F*) libs="$libs $1";; + -framework) libs="$libs $1 $2"; shift;; + -*) opts="$opts $1";; + *) break;; + esac + shift +done + +(echo "main() {" + for f in $*; do echo " (void) & $f;"; done + echo "}") >> hasgot.c + +if test "$verbose" = yes; then + echo "hasgot2 $args: $cc $opts -o tst hasgot.c $libs" >&2 + exec $cc $opts -o tst hasgot.c $libs > /dev/null +else + exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null +fi diff --git a/config/auto-aux/ia32sse2.c b/config/auto-aux/ia32sse2.c index cbe11462..8ba81601 100644 --- a/config/auto-aux/ia32sse2.c +++ b/config/auto-aux/ia32sse2.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/initgroups.c b/config/auto-aux/initgroups.c index b6e0ffbd..7b9c2398 100644 --- a/config/auto-aux/initgroups.c +++ b/config/auto-aux/initgroups.c @@ -1,6 +1,8 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ +/* */ +/* Contributed by Stephane Glondu */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ @@ -9,8 +11,6 @@ /* */ /***********************************************************************/ -/* Contributed by Stephane Glondu */ - /* $Id$ */ #include diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c index 6bdd2556..b087a3d6 100644 --- a/config/auto-aux/int64align.c +++ b/config/auto-aux/int64align.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/longlong.c b/config/auto-aux/longlong.c index bcdf4c97..424e540f 100644 --- a/config/auto-aux/longlong.c +++ b/config/auto-aux/longlong.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest index ce65bd07..c8d7c435 100755 --- a/config/auto-aux/runtest +++ b/config/auto-aux/runtest @@ -1,4 +1,18 @@ #!/bin/sh + +######################################################################### +# # +# 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 GNU Library General Public License, with # +# the special exception on linking described in file ../../LICENSE. # +# # +######################################################################### + if test "$verbose" = yes; then echo "runtest: $cc -o tst $* $cclibs" >&2 $cc -o tst $* $cclibs || exit 100 diff --git a/config/auto-aux/schar.c b/config/auto-aux/schar.c index 55d49f31..e3e81e39 100644 --- a/config/auto-aux/schar.c +++ b/config/auto-aux/schar.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/schar2.c b/config/auto-aux/schar2.c index d1d781a5..d041af18 100644 --- a/config/auto-aux/schar2.c +++ b/config/auto-aux/schar2.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/searchpath b/config/auto-aux/searchpath index 9b31267f..79d7fcae 100755 --- a/config/auto-aux/searchpath +++ b/config/auto-aux/searchpath @@ -1,4 +1,18 @@ #!/bin/sh + +######################################################################### +# # +# 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. # +# # +######################################################################### + # Find a program in the path IFS=':' diff --git a/config/auto-aux/setgroups.c b/config/auto-aux/setgroups.c index 5cfe49c0..63ac1b8c 100644 --- a/config/auto-aux/setgroups.c +++ b/config/auto-aux/setgroups.c @@ -1,6 +1,8 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ +/* */ +/* Contributed by Stephane Glondu */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ @@ -9,8 +11,6 @@ /* */ /***********************************************************************/ -/* Contributed by Stephane Glondu */ - /* $Id$ */ #include diff --git a/config/auto-aux/sighandler.c b/config/auto-aux/sighandler.c index 7e748df5..b36557c5 100644 --- a/config/auto-aux/sighandler.c +++ b/config/auto-aux/sighandler.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/signals.c b/config/auto-aux/signals.c index df0a8b0b..78ba8de6 100644 --- a/config/auto-aux/signals.c +++ b/config/auto-aux/signals.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c index 992c47a6..58fd6b23 100644 --- a/config/auto-aux/sizes.c +++ b/config/auto-aux/sizes.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/solaris-ld b/config/auto-aux/solaris-ld index 3ab90bce..cc846a31 100644 --- a/config/auto-aux/solaris-ld +++ b/config/auto-aux/solaris-ld @@ -1,4 +1,18 @@ #!/bin/sh + +######################################################################### +# # +# 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. # +# # +######################################################################### + # Determine if gcc calls the Solaris ld or the GNU ld # Exit code is 0 for Solaris ld, 1 for GNU ld diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c index 39e4e832..47f252aa 100644 --- a/config/auto-aux/stackov.c +++ b/config/auto-aux/stackov.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c index 77c0bb72..84a94033 100644 --- a/config/auto-aux/tclversion.c +++ b/config/auto-aux/tclversion.c @@ -1,3 +1,21 @@ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + #include #include #include diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble new file mode 100644 index 00000000..feffbed2 --- /dev/null +++ b/config/auto-aux/tryassemble @@ -0,0 +1,7 @@ +#!/bin/sh +if test "$verbose" = yes; then +echo "tryassemble: $aspp -o tst $*" >&2 +$aspp -o tst $* || exit 100 +else +$aspp -o tst $* 2> /dev/null || exit 100 +fi diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile index 797a1c38..934a00a9 100755 --- a/config/auto-aux/trycompile +++ b/config/auto-aux/trycompile @@ -1,4 +1,18 @@ #!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 2002 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../LICENSE. # +# # +######################################################################### + if test "$verbose" = yes; then echo "trycompile: $cc -o tst $* $cclibs" >&2 $cc -o tst $* $cclibs || exit 100 diff --git a/config/gnu/config.guess b/config/gnu/config.guess index d25d58fe..8152efd6 100755 --- a/config/gnu/config.guess +++ b/config/gnu/config.guess @@ -1,9 +1,10 @@ #! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, +# 2011 Free Software Foundation, Inc. -timestamp='2004-02-16' +timestamp='2011-11-11' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -17,23 +18,25 @@ timestamp='2004-02-16' # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA +# 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. -# Originally written by Per Bothner . -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. + +# Originally written by Per Bothner. Please send patches (context +# diff format) to and include a ChangeLog +# entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # -# The plan is that this can be called by configure scripts if you -# don't specify an explicit build system type. +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD me=`echo "$0" | sed -e 's,.*/,,'` @@ -53,8 +56,9 @@ version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free +Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -66,11 +70,11 @@ Try \`$me --help' for more information." while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; + echo "$timestamp" ; exit ;; --version | -v ) - echo "$version" ; exit 0 ;; + echo "$version" ; exit ;; --help | --h* | -h ) - echo "$usage"; exit 0 ;; + echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. @@ -104,7 +108,7 @@ set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d -q "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; @@ -123,7 +127,7 @@ case $CC_FOR_BUILD,$HOST_CC,$CC in ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ;' +esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) @@ -158,6 +162,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched @@ -166,7 +171,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep __ELF__ >/dev/null + | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? @@ -176,7 +181,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in fi ;; *) - os=netbsd + os=netbsd ;; esac # The OS release @@ -196,68 +201,32 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" - exit 0 ;; - amd64:OpenBSD:*:*) - echo x86_64-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - amiga:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - arc:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - cats:OpenBSD:*:*) - echo arm-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - hp300:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mac68k:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - macppc:OpenBSD:*:*) - echo powerpc-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvme68k:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvme88k:OpenBSD:*:*) - echo m88k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvmeppc:OpenBSD:*:*) - echo powerpc-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - pegasos:OpenBSD:*:*) - echo powerpc-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - pmax:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - sgi:OpenBSD:*:*) - echo mipseb-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - sun3:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - wgrisc:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; + exit ;; *:OpenBSD:*:*) - echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} - exit 0 ;; + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; macppc:MirBSD:*:*) - echo powerppc-unknown-mirbsd${UNAME_RELEASE} - exit 0 ;; + echo powerpc-unknown-mirbsd${UNAME_RELEASE} + exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} - exit 0 ;; + exit ;; alpha:OSF1:*:*) - if test $UNAME_RELEASE = "V4.0"; then + case $UNAME_RELEASE in + *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - fi + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU @@ -295,45 +264,52 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac + # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - exit 0 ;; - Alpha*:OpenVMS:*:*) - echo alpha-hp-vms - exit 0 ;; + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + exitcode=$? + trap '' 0 + exit $exitcode ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix - exit 0 ;; + exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 - exit 0 ;; + exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 - exit 0;; + exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos - exit 0 ;; + exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos - exit 0 ;; + exit ;; *:OS/390:*:*) echo i370-ibm-openedition - exit 0 ;; + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; *:OS400:*:*) - echo powerpc-ibm-os400 - exit 0 ;; + echo powerpc-ibm-os400 + exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} - exit 0;; + exit ;; + arm:riscos:*:*|arm:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp - exit 0;; + exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then @@ -341,32 +317,51 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in else echo pyramid-pyramid-bsd fi - exit 0 ;; + exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 - exit 0 ;; + exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 - exit 0 ;; - DRS?6000:UNIX_SV:4.2*:7*) + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7 && exit 0 ;; + sparc) echo sparc-icl-nx7; exit ;; esac ;; + s390x:SunOS:*:*) + echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; + exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - i86pc:SunOS:5.*:*) - echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; + exit ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + echo i386-pc-auroraux${UNAME_RELEASE} + exit ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + eval $set_cc_for_build + SUN_ARCH="i386" + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH="x86_64" + fi + fi + echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; + exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) @@ -375,10 +370,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit 0 ;; + exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} - exit 0 ;; + exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 @@ -390,10 +385,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in echo sparc-sun-sunos${UNAME_RELEASE} ;; esac - exit 0 ;; + exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} - exit 0 ;; + exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor @@ -403,41 +398,41 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; + exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit 0 ;; + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit 0 ;; + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit 0 ;; + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} - exit 0 ;; + exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} - exit 0 ;; + exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 - exit 0 ;; + exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} - exit 0 ;; + exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} - exit 0 ;; + exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} - exit 0 ;; + exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c @@ -461,35 +456,36 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in exit (-1); } EOF - $CC_FOR_BUILD -o $dummy $dummy.c \ - && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ - && exit 0 + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} - exit 0 ;; + exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax - exit 0 ;; + exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax - exit 0 ;; + exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax - exit 0 ;; + exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix - exit 0 ;; + exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 - exit 0 ;; + exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 - exit 0 ;; + exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 - exit 0 ;; + exit ;; AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ @@ -502,29 +498,29 @@ EOF else echo i586-dg-dgux${UNAME_RELEASE} fi - exit 0 ;; + exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 - exit 0 ;; + exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 - exit 0 ;; + exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 - exit 0 ;; + exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd - exit 0 ;; + exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit 0 ;; + exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix - exit 0 ;; + exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` @@ -532,7 +528,7 @@ EOF IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit 0 ;; + exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build @@ -547,15 +543,19 @@ EOF exit(0); } EOF - $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0 - echo rs6000-ibm-aix3.2.5 + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi - exit 0 ;; - *:AIX:*:[45]) + exit ;; + *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 @@ -568,28 +568,28 @@ EOF IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit 0 ;; + exit ;; *:AIX:*:*) echo rs6000-ibm-aix - exit 0 ;; + exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 - exit 0 ;; + exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit 0 ;; # report: romp-ibm BSD 4.3 + exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx - exit 0 ;; + exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 - exit 0 ;; + exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd - exit 0 ;; + exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 - exit 0 ;; + exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in @@ -598,52 +598,52 @@ EOF 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac + esac ;; + esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c + sed 's/^ //' << EOF >$dummy.c - #define _HPUX_SOURCE - #include - #include + #define _HPUX_SOURCE + #include + #include - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa @@ -651,9 +651,19 @@ EOF esac if [ ${HP_ARCH} = "hppa2.0w" ] then - # avoid double evaluation of $set_cc_for_build - test -n "$CC_FOR_BUILD" || eval $set_cc_for_build - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E -) | grep __LP64__ >/dev/null + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ then HP_ARCH="hppa2.0w" else @@ -661,11 +671,11 @@ EOF fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit 0 ;; + exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} - exit 0 ;; + exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c @@ -693,224 +703,259 @@ EOF exit (0); } EOF - $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0 + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 - exit 0 ;; + exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd - exit 0 ;; + exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd - exit 0 ;; + exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix - exit 0 ;; + exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf - exit 0 ;; + exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf - exit 0 ;; + exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi - exit 0 ;; + exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites - exit 0 ;; + exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd - exit 0 ;; + exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi - exit 0 ;; + exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd - exit 0 ;; + exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd - exit 0 ;; + exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd - exit 0 ;; + exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; + exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' - exit 0 ;; + exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; + exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; + exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; + exit ;; *:UNICOS/mp:*:*) - echo nv1-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit 0 ;; + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` - echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit 0 ;; + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit 0 ;; + exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; + exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; + exit ;; *:FreeBSD:*:*) - # Determine whether the default compiler uses glibc. - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - #if __GLIBC__ >= 2 - LIBC=gnu - #else - LIBC= - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` - # GNU/KFreeBSD systems have a "k" prefix to indicate we are using - # FreeBSD's kernel, but not the complete OS. - case ${LIBC} in gnu) kernel_only='k' ;; esac - echo ${UNAME_MACHINE}-unknown-${kernel_only}freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC} - exit 0 ;; + UNAME_PROCESSOR=`/usr/bin/uname -p` + case ${UNAME_PROCESSOR} in + amd64) + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin - exit 0 ;; - i*:MINGW*:*) + exit ;; + *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 - exit 0 ;; + exit ;; + i*:MSYS*:*) + echo ${UNAME_MACHINE}-pc-msys + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 - exit 0 ;; - x86:Interix*:[34]*) - echo i586-pc-interix${UNAME_RELEASE}|sed -e 's/\..*//' - exit 0 ;; + exit ;; + *:Interix*:*) + case ${UNAME_MACHINE} in + x86) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + authenticamd | genuineintel | EM64T) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + IA64) + echo ia64-unknown-interix${UNAME_RELEASE} + exit ;; + esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks - exit 0 ;; + exit ;; + 8664:Windows_NT:*) + echo x86_64-pc-mks + exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix - exit 0 ;; + exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin - exit 0 ;; + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin - exit 0 ;; + exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; + exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit 0 ;; + exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu - exit 0 ;; + exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix - exit 0 ;; + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit ;; arm*:Linux:*:*) + eval $set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + echo ${UNAME_MACHINE}-unknown-linux-gnu + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo ${UNAME_MACHINE}-unknown-linux-gnueabi + else + echo ${UNAME_MACHINE}-unknown-linux-gnueabihf + fi + fi + exit ;; + avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - sa110:Linux:*:*) - echo arm-unknown-linux-gnu - exit 0 ;; + exit ;; cris:Linux:*:*) echo cris-axis-linux-gnu - exit 0 ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - mips:Linux:*:*) + exit ;; + crisv32:Linux:*:*) + echo crisv32-axis-linux-gnu + exit ;; + frv:Linux:*:*) + echo frv-unknown-linux-gnu + exit ;; + hexagon:Linux:*:*) + echo hexagon-unknown-linux-gnu + exit ;; + i*86:Linux:*:*) + LIBC=gnu eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips - #undef mipsel - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mipsel - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips - #else - CPU= - #endif + #ifdef __dietlibc__ + LIBC=dietlibc #endif EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` - test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0 - ;; - mips64:Linux:*:*) + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` + echo "${UNAME_MACHINE}-pc-linux-${LIBC}" + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU - #undef mips64 - #undef mips64el + #undef ${UNAME_MACHINE} + #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mips64el + CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips64 + CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` - test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0 + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-gnu - exit 0 ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-gnu - exit 0 ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null - if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} - exit 0 ;; + or32:Linux:*:*) + echo or32-unknown-linux-gnu + exit ;; + padre:Linux:*:*) + echo sparc-unknown-linux-gnu + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in @@ -918,115 +963,71 @@ EOF PA8*) echo hppa2.0-unknown-linux-gnu ;; *) echo hppa-unknown-linux-gnu ;; esac - exit 0 ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu - exit 0 ;; + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux - exit 0 ;; + exit ;; sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; + exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; + exit ;; + tile*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-gnu + exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu - exit 0 ;; - i*86:Linux:*:*) - # The BFD linker knows what the default object file format is, so - # first see if it will tell us. cd to the root directory to prevent - # problems with other programs or directories called `ld' in the path. - # Set LC_ALL=C to ensure ld outputs messages in English. - ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ - | sed -ne '/supported targets:/!d - s/[ ][ ]*/ /g - s/.*supported targets: *// - s/ .*// - p'` - case "$ld_supported_targets" in - elf32-i386) - TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" - ;; - a.out-i386-linux) - echo "${UNAME_MACHINE}-pc-linux-gnuaout" - exit 0 ;; - coff-i386) - echo "${UNAME_MACHINE}-pc-linux-gnucoff" - exit 0 ;; - "") - # Either a pre-BFD a.out linker (linux-gnuoldld) or - # one that does not give us useful --help. - echo "${UNAME_MACHINE}-pc-linux-gnuoldld" - exit 0 ;; - esac - # Determine whether the default compiler is a.out or elf - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - #ifdef __ELF__ - # ifdef __GLIBC__ - # if __GLIBC__ >= 2 - LIBC=gnu - # else - LIBC=gnulibc1 - # endif - # else - LIBC=gnulibc1 - # endif - #else - #ifdef __INTEL_COMPILER - LIBC=gnu - #else - LIBC=gnuaout - #endif - #endif - #ifdef __dietlibc__ - LIBC=dietlibc - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` - test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0 - test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0 - ;; + exit ;; + xtensa*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 - exit 0 ;; + exit ;; i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. + # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit 0 ;; + exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx - exit 0 ;; + exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop - exit 0 ;; + exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos - exit 0 ;; - i*86:syllable:*:*) + exit ;; + i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable - exit 0 ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; + exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit 0 ;; + exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then @@ -1034,15 +1035,16 @@ EOF else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi - exit 0 ;; - i*86:*:5:[78]*) + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit 0 ;; + exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi - exit 0 ;; + exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv - exit 0 ;; + exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv - exit 0 ;; + exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix - exit 0 ;; - M68*:*:R3V[567]*:*) - test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; - 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0) + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4.3${OS_REL} && exit 0 + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4 && exit 0 ;; + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; + exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 - exit 0 ;; + exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; + exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; + exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} - exit 0 ;; + exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 - exit 0 ;; + exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 - exit 0 ;; + exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` @@ -1134,71 +1149,94 @@ EOF else echo ns32k-sni-sysv fi - exit 0 ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit 0 ;; + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 - exit 0 ;; + exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 - exit 0 ;; + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos - exit 0 ;; + exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} - exit 0 ;; + exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 - exit 0 ;; + exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} + echo mips-nec-sysv${UNAME_RELEASE} else - echo mips-unknown-sysv${UNAME_RELEASE} + echo mips-unknown-sysv${UNAME_RELEASE} fi - exit 0 ;; + exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos - exit 0 ;; + exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos - exit 0 ;; + exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos - exit 0 ;; + exit ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + echo i586-pc-haiku + exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} - exit 0 ;; + exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} - exit 0 ;; - osfmach3_ppc:*:*:*) - echo powerpc-unknown-linux - exit 0 ;; + exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} - exit 0 ;; + exit ;; + SX-7:SUPER-UX:*:*) + echo sx7-nec-superux${UNAME_RELEASE} + exit ;; + SX-8:SUPER-UX:*:*) + echo sx8-nec-superux${UNAME_RELEASE} + exit ;; + SX-8R:SUPER-UX:*:*) + echo sx8r-nec-superux${UNAME_RELEASE} + exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit 0 ;; + exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit 0 ;; + exit ;; *:Darwin:*:*) - case `uname -p` in - *86) UNAME_PROCESSOR=i686 ;; - powerpc) UNAME_PROCESSOR=powerpc ;; + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + case $UNAME_PROCESSOR in + i386) + eval $set_cc_for_build + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + UNAME_PROCESSOR="x86_64" + fi + fi ;; + unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit 0 ;; + exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then @@ -1206,22 +1244,28 @@ EOF UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit 0 ;; + exit ;; *:QNX:*:4*) echo i386-pc-qnx - exit 0 ;; + exit ;; + NEO-?:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk${UNAME_RELEASE} + exit ;; + NSE-?:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} - exit 0 ;; + exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux - exit 0 ;; + exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv - exit 0 ;; + exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit 0 ;; + exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 @@ -1232,31 +1276,50 @@ EOF UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 - exit 0 ;; + exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 - exit 0 ;; + exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex - exit 0 ;; + exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 - exit 0 ;; + exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 - exit 0 ;; + exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 - exit 0 ;; + exit ;; *:ITS:*:*) echo pdp10-unknown-its - exit 0 ;; + exit ;; SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit 0 ;; + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit 0 ;; + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; + i*86:AROS:*:*) + echo ${UNAME_MACHINE}-pc-aros + exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 @@ -1279,16 +1342,16 @@ main () #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 - "4" + "4" #else - "" + "" #endif - ); exit (0); + ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix"); exit (0); + printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) @@ -1296,16 +1359,15 @@ main () #endif #if defined (NeXT) - char * arch; - int version; #if !defined (__ARCHITECTURE__) - arch = "m68k"; -#else - arch = __ARCHITECTURE__; - if (strcmp(arch, "hppa") == 0) arch = "hppa1.1"; +#define __ARCHITECTURE__ "m68k" #endif + int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - printf ("%s-next-nextstep%d\n", arch, version); + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif @@ -1378,11 +1440,12 @@ main () } EOF -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && $dummy && exit 0 +$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) @@ -1391,22 +1454,22 @@ then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd - exit 0 ;; + exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi - exit 0 ;; + exit ;; c34*) echo c34-convex-bsd - exit 0 ;; + exit ;; c38*) echo c38-convex-bsd - exit 0 ;; + exit ;; c4*) echo c4-convex-bsd - exit 0 ;; + exit ;; esac fi @@ -1417,7 +1480,9 @@ This script, last modified $timestamp, has failed to recognize the operating system you are using. It is advised that you download the most up to date version of the config scripts from - ftp://ftp.gnu.org/pub/gnu/config/ + http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +and + http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD If the version you run ($0) is already up to date, please send the following data and any information you think might be diff --git a/config/gnu/config.sub b/config/gnu/config.sub index d2e3557a..e76eaf47 100755 --- a/config/gnu/config.sub +++ b/config/gnu/config.sub @@ -1,9 +1,10 @@ #! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, +# 2011 Free Software Foundation, Inc. -timestamp='2004-02-16' +timestamp='2011-11-11' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software @@ -21,22 +22,26 @@ timestamp='2004-02-16' # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. - +# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA +# 02110-1301, USA. +# # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. + # Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. +# diff and a properly formatted GNU ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. @@ -70,8 +75,9 @@ Report bugs and patches to ." version="\ GNU config.sub ($timestamp) -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free +Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -83,11 +89,11 @@ Try \`$me --help' for more information." while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; + echo "$timestamp" ; exit ;; --version | -v ) - echo "$version" ; exit 0 ;; + echo "$version" ; exit ;; --help | --h* | -h ) - echo "$usage"; exit 0 ;; + echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. @@ -99,7 +105,7 @@ while test $# -gt 0 ; do *local*) # First pass through any local machine types. echo $1 - exit 0;; + exit ;; * ) break ;; @@ -118,8 +124,11 @@ esac # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in - nto-qnx* | linux-gnu* | linux-dietlibc | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | \ - kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*) + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ + linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | \ + kopensolaris*-gnu* | \ + storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; @@ -145,10 +154,13 @@ case $os in -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis) + -apple | -axis | -knuth | -cray | -microblaze) os= basic_machine=$1 ;; + -bluegene*) + os=-cnk + ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 @@ -163,13 +175,17 @@ case $os in os=-chorusos basic_machine=$1 ;; - -chorusrdb) - os=-chorusrdb + -chorusrdb) + os=-chorusrdb basic_machine=$1 - ;; + ;; -hiux*) os=-hiuxwe2 ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` @@ -186,6 +202,10 @@ case $os in # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` @@ -230,22 +250,32 @@ case $basic_machine in | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ - | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ + | be32 | be64 \ + | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ - | fr30 | frv \ + | epiphany \ + | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ - | m32r | m68000 | m68k | m88k | mcore \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | maxq | mb | microblaze | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ - | mips64vr | mips64vrel \ + | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ @@ -254,30 +284,63 @@ case $basic_machine in | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ + | moxie \ + | mt \ | msp430 \ + | nds32 | nds32le | nds32be \ + | nios | nios2 \ | ns16k | ns32k \ - | openrisc | or32 \ + | open8 \ + | or32 \ | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ | pyramid \ - | sh | sh[1234] | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ - | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ - | strongarm \ - | tahoe | thumb | tic4x | tic80 | tron \ - | v850 | v850e \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | we32k \ - | x86 | xscale | xstormy16 | xtensa \ - | z8k) + | x86 | xc16x | xstormy16 | xtensa \ + | z8k | z80) basic_machine=$basic_machine-unknown ;; - m6811 | m68hc11 | m6812 | m68hc12) + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12 | picochip) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; + ms1) + basic_machine=mt-unknown + ;; + + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and @@ -297,28 +360,35 @@ case $basic_machine in | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* \ - | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ - | clipper-* | cydra-* \ + | avr-* | avr32-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ - | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ - | m32r-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | mcore-* \ + | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ - | mips64vr-* | mips64vrel-* \ + | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ @@ -326,26 +396,39 @@ case $basic_machine in | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ | msp430-* \ - | none-* | np1-* | nv1-* | ns16k-* | ns32k-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nios-* | nios2-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pyramid-* \ - | romp-* | rs6000-* \ - | sh-* | sh[1234]-* | sh[23]e-* | sh[34]eb-* | shbe-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ - | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ - | tahoe-* | thumb-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ + | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tile*-* \ | tron-* \ - | v850-* | v850e-* | vax-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ | we32k-* \ - | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ - | xtensa-* \ + | x86-* | x86_64-* | xc16x-* | xps100-* \ + | xstormy16-* | xtensa*-* \ | ymp-* \ - | z8k-*) + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. @@ -363,7 +446,7 @@ case $basic_machine in basic_machine=a29k-amd os=-udi ;; - abacus) + abacus) basic_machine=abacus-unknown ;; adobe68k) @@ -409,6 +492,10 @@ case $basic_machine in basic_machine=m68k-apollo os=-bsd ;; + aros) + basic_machine=i386-pc + os=-aros + ;; aux) basic_machine=m68k-apple os=-aux @@ -417,10 +504,35 @@ case $basic_machine in basic_machine=ns32k-sequent os=-dynix ;; + blackfin) + basic_machine=bfin-unknown + os=-linux + ;; + blackfin-*) + basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=-cnk + ;; + c54x-*) + basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; c90) basic_machine=c90-cray os=-unicos ;; + cegcc) + basic_machine=arm-unknown + os=-cegcc + ;; convex-c1) basic_machine=c1-convex os=-bsd @@ -445,16 +557,27 @@ case $basic_machine in basic_machine=j90-cray os=-unicos ;; - cr16c) - basic_machine=cr16c-unknown + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; da30 | da30-*) basic_machine=m68k-da30 ;; @@ -477,6 +600,14 @@ case $basic_machine in basic_machine=m88k-motorola os=-sysv3 ;; + dicos) + basic_machine=i686-pc + os=-dicos + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx @@ -627,6 +758,14 @@ case $basic_machine in basic_machine=m68k-isi os=-sysv ;; + m68knommu) + basic_machine=m68k-unknown + os=-linux + ;; + m68knommu-*) + basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; m88k-omron*) basic_machine=m88k-omron ;; @@ -638,10 +777,17 @@ case $basic_machine in basic_machine=ns32k-utek os=-sysv ;; + microblaze) + basic_machine=microblaze-xilinx + ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; + mingw32ce) + basic_machine=arm-unknown + os=-mingw32ce + ;; miniframe) basic_machine=m68000-convergent ;; @@ -655,10 +801,6 @@ case $basic_machine in mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; - mmix*) - basic_machine=mmix-knuth - os=-mmixware - ;; monitor) basic_machine=m68k-rom68k os=-coff @@ -671,10 +813,21 @@ case $basic_machine in basic_machine=i386-pc os=-msdos ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + msys) + basic_machine=i386-pc + os=-msys + ;; mvs) basic_machine=i370-ibm os=-mvs ;; + nacl) + basic_machine=le32-unknown + os=-nacl + ;; ncr3000) basic_machine=i486-ncr os=-sysv4 @@ -739,9 +892,11 @@ case $basic_machine in np1) basic_machine=np1-gould ;; - nv1) - basic_machine=nv1-cray - os=-unicosmp + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem @@ -750,9 +905,8 @@ case $basic_machine in basic_machine=hppa1.1-oki os=-proelf ;; - or32 | or32-*) + openrisc | openrisc-*) basic_machine=or32-unknown - os=-coff ;; os400) basic_machine=powerpc-ibm @@ -774,6 +928,14 @@ case $basic_machine in basic_machine=i860-intel os=-osf ;; + parisc) + basic_machine=hppa-unknown + os=-linux + ;; + parisc-*) + basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; pbd) basic_machine=sparc-tti ;; @@ -783,6 +945,12 @@ case $basic_machine in pc532 | pc532-*) basic_machine=ns32k-pc532 ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; @@ -812,9 +980,10 @@ case $basic_machine in ;; power) basic_machine=power-ibm ;; - ppc) basic_machine=powerpc-unknown + ppc | ppcbe) basic_machine=powerpc-unknown ;; - ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown @@ -839,6 +1008,10 @@ case $basic_machine in basic_machine=i586-unknown os=-pw32 ;; + rdos) + basic_machine=i386-pc + os=-rdos + ;; rom68k) basic_machine=m68k-rom68k os=-coff @@ -865,6 +1038,10 @@ case $basic_machine in sb1el) basic_machine=mipsisa64sb1el-unknown ;; + sde) + basic_machine=mipsisa32-sde + os=-elf + ;; sei) basic_machine=mips-sei os=-seiux @@ -876,6 +1053,9 @@ case $basic_machine in basic_machine=sh-hitachi os=-hms ;; + sh5el) + basic_machine=sh5le-unknown + ;; sh64) basic_machine=sh64-unknown ;; @@ -897,6 +1077,9 @@ case $basic_machine in basic_machine=i860-stratus os=-sysv4 ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; sun2) basic_machine=m68000-sun ;; @@ -953,17 +1136,9 @@ case $basic_machine in basic_machine=t90-cray os=-unicos ;; - tic54x | c54x*) - basic_machine=tic54x-unknown - os=-coff - ;; - tic55x | c55x*) - basic_machine=tic55x-unknown - os=-coff - ;; - tic6x | c6x*) - basic_machine=tic6x-unknown - os=-coff + tile*) + basic_machine=$basic_machine-unknown + os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown @@ -1025,9 +1200,16 @@ case $basic_machine in basic_machine=hppa1.1-winbond os=-proelf ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; xps | xps100) basic_machine=xps100-honeywell ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` + ;; ymp) basic_machine=ymp-cray os=-unicos @@ -1036,6 +1218,10 @@ case $basic_machine in basic_machine=z8k-unknown os=-sim ;; + z80-*-coff) + basic_machine=z80-unknown + os=-sim + ;; none) basic_machine=none-none os=-none @@ -1055,6 +1241,9 @@ case $basic_machine in romp) basic_machine=romp-ibm ;; + mmix) + basic_machine=mmix-knuth + ;; rs6000) basic_machine=rs6000-ibm ;; @@ -1071,13 +1260,10 @@ case $basic_machine in we32k) basic_machine=we32k-att ;; - sh3 | sh4 | sh[34]eb | sh[1234]le | sh[23]ele) + sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; - sh64) - basic_machine=sh64-unknown - ;; - sparc | sparcv9 | sparcv9b) + sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) @@ -1121,9 +1307,12 @@ esac if [ x"$os" != x"" ] then case $os in - # First match some system type aliases - # that might get confused with valid system types. + # First match some system type aliases + # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. + -auroraux) + os=-auroraux + ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; @@ -1144,26 +1333,31 @@ case $os in # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ + | -sym* | -kopensolaris* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* \ + | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* | -openbsd* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* \ - | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -linux-gnu* | -linux-uclibc* | -uxpv* | -beos* | -mpeix* | -udk* \ + | -chorusos* | -chorusrdb* | -cegcc* \ + | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -linux-android* \ + | -linux-newlib* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly*) + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) @@ -1181,7 +1375,7 @@ case $os in os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) @@ -1202,7 +1396,7 @@ case $os in -opened*) os=-openedition ;; - -os400*) + -os400*) os=-os400 ;; -wince*) @@ -1251,7 +1445,7 @@ case $os in -sinix*) os=-sysv4 ;; - -tpf*) + -tpf*) os=-tpf ;; -triton*) @@ -1290,6 +1484,14 @@ case $os in -kaos*) os=-kaos ;; + -zvmoe) + os=-zvmoe + ;; + -dicos*) + os=-dicos + ;; + -nacl*) + ;; -none) ;; *) @@ -1312,6 +1514,12 @@ else # system, and we'll never get to this point. case $basic_machine in + score-*) + os=-elf + ;; + spu-*) + os=-elf + ;; *-acorn) os=-riscix1.2 ;; @@ -1321,9 +1529,18 @@ case $basic_machine in arm*-semi) os=-aout ;; - c4x-* | tic4x-*) - os=-coff - ;; + c4x-* | tic4x-*) + os=-coff + ;; + tic54x-*) + os=-coff + ;; + tic55x-*) + os=-coff + ;; + tic6x-*) + os=-coff + ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 @@ -1349,6 +1566,9 @@ case $basic_machine in m68*-cisco) os=-aout ;; + mep-*) + os=-elf + ;; mips*-cisco) os=-elf ;; @@ -1367,9 +1587,15 @@ case $basic_machine in *-be) os=-beos ;; + *-haiku) + os=-haiku + ;; *-ibm) os=-aix ;; + *-knuth) + os=-mmixware + ;; *-wec) os=-proelf ;; @@ -1472,7 +1698,7 @@ case $basic_machine in -sunos*) vendor=sun ;; - -aix*) + -cnk*|-aix*) vendor=ibm ;; -beos*) @@ -1535,7 +1761,7 @@ case $basic_machine in esac echo $basic_machine$os -exit 0 +exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) diff --git a/config/m-nt.h b/config/m-nt.h index 7a928281..80e0b5ee 100644 --- a/config/m-nt.h +++ b/config/m-nt.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/m-templ.h b/config/m-templ.h index 392ec562..6e09f64e 100644 --- a/config/m-templ.h +++ b/config/m-templ.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/config/s-nt.h b/config/s-nt.h index 5eaf3770..b21b7158 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -27,3 +27,4 @@ #define HAS_MKTIME #define HAS_PUTENV #define HAS_LOCALE +#define HAS_BROKEN_PRINTF diff --git a/config/s-templ.h b/config/s-templ.h index a65b178a..971bc48f 100644 --- a/config/s-templ.h +++ b/config/s-templ.h @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -52,10 +52,10 @@ /* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code via dlopen() is available. */ -#define HAS_EXPM1_LOG1P +#define HAS_C99_FLOAT_OPS -/* Define HAS_EXPM1_LOG1P if the math functions expm1() and log1p() - are available. (Standard C99 but not C89.) */ +/* Define HAS_C99_FLOAT_OPS if conforms to ISO C99. + In particular, it should provide expm1(), log1p(), hypot(), copysign(). */ /* 2. For the Unix library. */ diff --git a/configure b/configure index 47cc2035..4ed6ce1b 100755 --- a/configure +++ b/configure @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -31,6 +31,7 @@ mathlib='-lm' dllib='' x11_include_dir='' x11_lib_dir='' +graph_wanted=yes tk_wanted=yes pthread_wanted=yes tk_defs='' @@ -39,9 +40,11 @@ tk_x11=yes dl_defs='' verbose=no withcurses=yes +debugruntime=noruntimed withsharedlibs=yes gcc_warnings="-Wall" partialld="ld -r" +withcamlp4=camlp4 # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -81,14 +84,15 @@ while : ; do asppoption="$2"; shift;; -lib*) cclibs="$2 $cclibs"; shift;; - -no-curses) + -no-curses|--no-curses) withcurses=no;; - -no-shared-libs) + -no-shared-libs|--no-shared-libs) withsharedlibs=no;; -x11include*|--x11include*) x11_include_dir=$2; shift;; -x11lib*|--x11lib*) x11_lib_dir=$2; shift;; + -no-graph|--no-graph) graph_wanted=no;; -with-pthread*|--with-pthread*) ;; # Ignored for backward compatibility -no-pthread*|--no-pthread*) @@ -109,6 +113,10 @@ while : ; do dllib="$2"; shift;; -verbose|--verbose) verbose=yes;; + -with-debug-runtime|--with-debug-runtime) + debugruntime=runtimed;; + -no-camlp4|--no-camlp4) + withcamlp4="";; *) echo "Unknown option \"$1\"." 1>&2; exit 2;; esac shift @@ -123,17 +131,23 @@ esac case "$bindir" in /*) ;; "") ;; - *) echo "The -bindir directory must be absolute." 1>&2; exit 2;; + '$(PREFIX)/'*) ;; + *) echo 'The -bindir directory must be absolute or relative to $(PREFIX).'>&2 + exit 2;; esac case "$libdir" in /*) ;; "") ;; - *) echo "The -libdir directory must be absolute." 1>&2; exit 2;; + '$(PREFIX)/'*) ;; + *) echo 'The -libdir directory must be absolute or relative to $(PREFIX).'>&2 + exit 2;; esac case "$mandir" in /*) ;; "") ;; - *) echo "The -mandir directory must be absolute." 1>&2; exit 2;; + '$(PREFIX)/'*) ;; + *) echo 'The -mandir directory must be absolute or relative to $(PREFIX).'>&2 + exit 2;; esac # Generate the files @@ -206,14 +220,14 @@ case "$host,$cc" in WARNING: you are using gcc version 2.7.2.1 on an Intel x86 processor. This version of gcc is known to generate incorrect code for the -Objective Caml runtime system on some Intel x86 machines. (The symptom +OCaml runtime system on some Intel x86 machines. (The symptom is a crash of boot/ocamlc when compiling stdlib/pervasives.mli.) In particular, the version of gcc 2.7.2.1 that comes with Linux RedHat 4.x / Intel is affected by this problem. Other Linux distributions might also be affected. If you are using one of these configurations, you are strongly advised to use another version of gcc, such as 2.95, which are -known to work well with Objective Caml. +known to work well with OCaml. Press to proceed or to stop. EOF @@ -222,7 +236,7 @@ EOF WARNING: you are using gcc version 2.96 on an Intel x86 processor. Certain patched versions of gcc 2.96 are known to generate incorrect -code for the Objective Caml runtime system. (The symptom is a segmentation +code for the OCaml runtime system. (The symptom is a segmentation violation on boot/ocamlc.) Those incorrectly patched versions can be found in RedHat 7.2 and Mandrake 8.0 and 8.1; other Linux distributions might also be affected. (See bug #57760 on bugzilla.redhat.com) @@ -259,7 +273,7 @@ case "$bytecc,$host" in bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC" mathlib="";; *,*-*-darwin*) - bytecccompopts="-fno-defer-pop -no-cpp-precomp $gcc_warnings" + bytecccompopts="-fno-defer-pop $gcc_warnings" mathlib="" # Tell gcc that we can use 32-bit code addresses for threaded code # unless we are compiled for a shared library (-fPIC option) @@ -306,7 +320,7 @@ case "$bytecc,$host" in bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" dllccompopts="-U_WIN32 -DCAML_DLL" if test $withsharedlibs = yes; then - flexlink="flexlink -chain cygwin -merge-manifest" + flexlink="flexlink -chain cygwin -merge-manifest -stack 16777216" flexdir=`$flexlink -where | dos2unix` if test -z "$flexdir"; then echo "flexlink not found: native shared libraries won't be available" @@ -340,7 +354,7 @@ sh ./runtest ansi.c case $? in 0) echo "The C compiler is ANSI-compliant.";; 1) echo "The C compiler $cc is not ANSI-compliant." - echo "You need an ANSI C compiler to build Objective Caml." + echo "You need an ANSI C compiler to build OCaml." exit 2;; *) echo "Unable to compile the test program." echo "Make sure the C compiler $cc is properly installed." @@ -359,7 +373,7 @@ case "$2,$3" in echo "#define ARCH_SIXTYFOUR" >> m.h arch64=true;; *,*) echo "This architecture seems to be neither 32 bits nor 64 bits." - echo "Objective Caml won't run on this architecture." + echo "OCaml won't run on this architecture." exit 2;; *) echo "Unable to compile the test program." echo "Make sure the C compiler $cc is properly installed." @@ -368,7 +382,7 @@ esac if test $1 != 4 && test $2 != 4 && test $4 != 4; then echo "Sorry, we can't find a 32-bit integer type" echo "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)" - echo "Objective Caml won't run on this architecture." + echo "OCaml won't run on this architecture." exit 2 fi @@ -410,7 +424,7 @@ fi if test $3 = 8 && test $int64_native = false; then echo "This architecture has 64-bit pointers but no 64-bit integer type." - echo "Objective Caml won't run on this architecture." + echo "OCaml won't run on this architecture." exit 2 fi @@ -423,7 +437,7 @@ case $? in 1) echo "This is a little-endian architecture." echo "#undef ARCH_BIG_ENDIAN" >> m.h;; 2) echo "This architecture seems to be neither big endian nor little endian." - echo "Objective Caml won't run on this architecture." + echo "OCaml won't run on this architecture." exit 2;; *) echo "Something went wrong during endianness determination." echo "You'll have to figure out endianness yourself" @@ -458,7 +472,7 @@ case "$host" in 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 "That's a safe bet: Objective Caml will work even if" + echo "That's a safe bet: OCaml will work even if" echo "this architecture has actually no alignment constraints." echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; esac;; @@ -484,7 +498,7 @@ if $int64_native; then 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: Objective Caml will work even if" + echo "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 @@ -576,13 +590,7 @@ if test $withsharedlibs = "yes"; then byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; - i[3456]86-*-darwin10.*) - mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress" - bytecccompopts="$dl_defs $bytecccompopts" - dl_needs_underscore=false - shared_libraries_supported=true - ;; - i[3456]86-*-darwin*) + i[3456]86-*-darwin[89].*) mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" bytecccompopts="$dl_defs $bytecccompopts" dl_needs_underscore=false @@ -620,11 +628,12 @@ if test $withsharedlibs = "yes"; then *-*-cygwin*) natdynlink=true;; i[3456]86-*-linux*) natdynlink=true;; x86_64-*-linux*) natdynlink=true;; - i[3456]86-*-darwin10.*) + i[3456]86-*-darwin[89].*) natdynlink=true;; + i[3456]86-*-darwin*) if test $arch64 == true; then natdynlink=true fi;; - i[3456]86-*-darwin[89]*) natdynlink=true;; + x86_64-*-darwin*) natdynlink=true;; powerpc64-*-linux*) natdynlink=true;; sparc-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; @@ -636,6 +645,7 @@ if test $withsharedlibs = "yes"; then i[345]86-*-netbsd*) natdynlink=true;; x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; + arm*-*-linux*) natdynlink=true;; esac fi @@ -653,13 +663,6 @@ model=default system=unknown case "$host" in - alpha*-*-osf*) arch=alpha; system=digital;; - alpha*-*-linux*) arch=alpha; system=linux;; - alpha*-*-gnu*) arch=alpha; system=gnu;; - alpha*-*-freebsd*) arch=alpha; system=freebsd;; - alpha*-*-netbsd*) arch=alpha; system=netbsd;; - alpha*-*-openbsd*) arch=alpha; system=openbsd;; - sparc*-*-sunos4.*) arch=sparc; system=sunos;; sparc*-*-solaris2.*) arch=sparc; system=solaris;; sparc*-*-*bsd*) arch=sparc; system=bsd;; sparc*-*-linux*) arch=sparc; system=linux;; @@ -680,27 +683,24 @@ case "$host" in arch=i386; system=macosx fi;; i[3456]86-*-gnu*) arch=i386; system=gnu;; - mips-*-irix6*) arch=mips; system=irix;; - hppa1.1-*-hpux*) arch=hppa; system=hpux;; - hppa2.0*-*-hpux*) arch=hppa; system=hpux;; - hppa*-*-linux*) arch=hppa; system=linux;; - hppa*-*-gnu*) arch=hppa; system=gnu;; powerpc*-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody if $arch64; then model=ppc64; else model=ppc; fi;; - arm*-*-linux*) arch=arm; system=linux;; - arm*-*-gnu*) arch=arm; system=gnu;; - ia64-*-linux*) arch=ia64; system=linux;; - ia64-*-gnu*) arch=ia64; system=gnu;; - ia64-*-freebsd*) arch=ia64; system=freebsd;; + 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;; + armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;; + armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;; + armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;; + arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;; x86_64-*-linux*) arch=amd64; system=linux;; x86_64-*-gnu*) arch=amd64; system=gnu;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; - x86_64-*-darwin9.5) arch=amd64; system=macosx;; + x86_64-*-darwin*) arch=amd64; system=macosx;; esac # Some platforms exist both in 32-bit and 64-bit variants, not distinguished @@ -709,17 +709,13 @@ esac if $arch64; then case "$arch,$model" in - sparc,default|mips,default|hppa,default|power,ppc) + sparc,default|power,ppc) arch=none; model=default; system=unknown;; esac fi if test -z "$ccoption"; then - case "$arch,$system,$cc" in - alpha,digital,gcc*) nativecc=cc;; - mips,*,gcc*) nativecc=cc;; - *) nativecc="$bytecc";; - esac + nativecc="$bytecc" else nativecc="$ccoption" fi @@ -729,9 +725,6 @@ nativecclinkopts='' nativeccrpath="$byteccrpath" case "$arch,$nativecc,$system,$host_type" in - alpha,cc*,digital,*) nativecccompopts=-std1;; - mips,cc*,irix,*) nativecccompopts=-n32 - nativecclinkopts="-n32 -Wl,-woff,84";; *,*,nextstep,*) nativecccompopts="$gcc_warnings -U__GNUC__ -posix" nativecclinkopts="-posix";; *,*,rhapsody,*darwin[1-5].*) @@ -747,11 +740,6 @@ esac asppprofflags='-DPROFILING' case "$arch,$model,$system" in - alpha,*,digital) as='as -O2 -nocpp' - aspp='as -O2' - asppprofflags='-pg -DPROFILING';; - alpha,*,*) as='as' - aspp='gcc -c';; amd64,*,macosx) as='as -arch x86_64' aspp='gcc -arch x86_64 -c';; amd64,*,solaris) as='as --64' @@ -760,16 +748,10 @@ case "$arch,$model,$system" in aspp='gcc -c';; arm,*,*) as='as'; aspp='gcc -c';; - hppa,*,*) as='as'; - aspp='gcc -traditional -c';; i386,*,solaris) as='as' aspp='/usr/ccs/bin/as -P';; i386,*,*) as='as' aspp='gcc -c';; - ia64,*,*) as='as -xexplicit' - aspp='gcc -c -Wa,-xexplicit';; - mips,*,irix) as='as -n32 -O2 -nocpp -g0' - aspp='as -n32 -O2';; power,*,elf) as='as -u -m ppc' aspp='gcc -c';; power,*,bsd) as='as' @@ -790,7 +772,6 @@ if test -n "$asppoption"; then aspp="$asppoption"; fi cc_profile='-pg' case "$arch,$model,$system" in - alpha,*,digital) profiling='prof';; i386,*,linux_elf) profiling='prof';; i386,*,gnu) profiling='prof';; i386,*,bsd_elf) profiling='prof';; @@ -801,6 +782,7 @@ case "$arch,$model,$system" in case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; amd64,*,linux) profiling='prof';; amd64,*,gnu) profiling='prof';; + arm,*,linux*) profiling='prof';; *) profiling='noprof';; esac @@ -816,6 +798,9 @@ else echo "RANLIBCMD=" >> Makefile fi +echo "ARCMD=ar" >> Makefile + + # Do #! scripts work? if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then @@ -867,9 +852,9 @@ fi # For the Pervasives module -if sh ./trycompile expm1.c $mathlib; then - echo "expm1() and log1p() found." - echo "#define HAS_EXPM1_LOG1P" >> s.h +if sh ./hasgot2 -i math.h $mathlib expm1 log1p hypot copysign; then + echo "expm1(), log1p(), hypot(), copysign() found." + echo "#define HAS_C99_FLOAT_OPS" >> s.h fi # For the Sys module @@ -1056,14 +1041,7 @@ if sh ./hasgot -i termios.h && echo "#define HAS_TERMIOS" >> s.h fi -# Async I/O under OSF1 3.x are so buggy that the test program hangs... -testasyncio=true -if test -f /usr/bin/uname; then - case "`/usr/bin/uname -s -r`" in - "OSF1 V3."*) testasyncio=false;; - esac -fi -if $testasyncio && sh ./runtest async_io.c; then +if sh ./runtest async_io.c; then echo "Asynchronous I/O are supported." echo "#define HAS_ASYNC_IO" >> s.h fi @@ -1138,6 +1116,11 @@ if sh ./hasgot -i sys/types.h -i sys/mman.h && sh ./hasgot mmap munmap; then echo "#define HAS_MMAP" >> s.h fi +if sh ./hasgot pwrite; then + echo "pwrite() found" + echo "#define HAS_PWRITE" >> s.h +fi + nargs=none for i in 5 6; do if sh ./trycompile -DNUM_ARGS=${i} gethostbyname.c; then nargs=$i; break; fi @@ -1170,7 +1153,7 @@ fi # Determine if system stack overflows can be detected case "$arch,$system" in - i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx|amd64,macosx) + i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx) echo "System stack overflow can be detected." echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; *) @@ -1180,13 +1163,11 @@ esac # Determine the target architecture for the "num" library case "$arch" in - alpha) bng_arch=alpha; bng_asm_level=1;; i386) bng_arch=ia32 if sh ./trycompile ia32sse2.c then bng_asm_level=2 else bng_asm_level=1 fi;; - mips) bng_arch=mips; bng_asm_level=1;; power) bng_arch=ppc; bng_asm_level=1;; amd64) bng_arch=amd64; bng_asm_level=1;; *) bng_arch=generic; bng_asm_level=0;; @@ -1253,10 +1234,22 @@ fi # Determine the location of X include files and libraries +# If the user specified -x11include and/or -x11lib, these settings +# are used. Otherwise, we check whether there is pkg-config, and take +# the flags from there. Otherwise, we search the location. + x11_include="not found" x11_link="not found" -for dir in \ +if test -z "$x11_include_dir" -a -z "$x11_lib_dir"; then + if pkg-config --exists x11 2>/dev/null; then + x11_include=`pkg-config --cflags x11` + x11_link=`pkg-config --libs x11` + fi +fi + +if test "$x11_include" = "not found"; then + for dir in \ $x11_include_dir \ \ /usr/X11R7/include \ @@ -1302,20 +1295,21 @@ for dir in \ /usr/openwin/include \ /usr/openwin/share/include \ ; \ -do - if test -f $dir/X11/X.h; then - x11_include=$dir - break - fi -done + do + if test -f $dir/X11/X.h; then + x11_include_dir=$dir + x11_include="-I$dir" + break + fi + done -if test "$x11_include" = "not found"; then - x11_try_lib_dir='' -else - x11_try_lib_dir=`echo $x11_include | sed -e 's|include|lib|'` -fi + if test "$x11_include" = "not found"; then + x11_try_lib_dir='' + else + x11_try_lib_dir=`echo $x11_include_dir | sed -e 's|include|lib|'` + fi -for dir in \ + for dir in \ $x11_lib_dir \ $x11_try_lib_dir \ \ @@ -1357,93 +1351,62 @@ for dir in \ /lib/usr/lib/X11 \ \ /usr/openwin/lib \ - /usr/openwin/share/lib \ + /usr/openwin/share/lib \ + \ + /usr/lib/i386-linux-gnu \ + /usr/lib/x86_64-linux-gnu \ ; \ -do - if test -f $dir/libX11.a || \ - test -f $dir/libX11.so || \ - test -f $dir/libX11.dll.a || \ - test -f $dir/libX11.dylib || \ - test -f $dir/libX11.sa; then - if test $dir = /usr/lib; then - x11_link="-lX11" - else - x11_libs="-L$dir" - case "$host" in - *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; - *) x11_link="-L$dir -lX11";; - esac + do + if test -f $dir/libX11.a || \ + test -f $dir/libX11.so || \ + test -f $dir/libX11.dll.a || \ + test -f $dir/libX11.dylib || \ + test -f $dir/libX11.sa; then + if test $dir = /usr/lib; then + x11_link="-lX11" + else + x11_libs="-L$dir" + case "$host" in + *-kfreebsd*-gnu) x11_link="-L$dir -lX11";; + *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; + *) x11_link="-L$dir -lX11";; + esac + fi + break fi - break - fi -done + done +fi +if test "x11_include" != "not found"; then + if test "$x11_include" = "-I/usr/include"; then + x11_include="" + fi + if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then + echo "X11 works" + else + echo "Cannot compile X11 program" + x11_include="not found" + fi +fi +has_graph=false if test "$x11_include" = "not found" || test "$x11_link" = "not found" then echo "X11 not found, the \"graph\" library will not be supported." - x11_include="" + x11_include="not found" + x11_link="not found" else - echo "Location of X11 include files: $x11_include/X11" + echo "Options for compiling for X11: $x11_include" echo "Options for linking with X11: $x11_link" - otherlibraries="$otherlibraries graph" - if test "$x11_include" = "/usr/include"; then - x11_include="" - else - x11_include="-I$x11_include" + if test "$graph_wanted" = yes + then + has_graph=true + otherlibraries="$otherlibraries graph" fi fi echo "X11_INCLUDES=$x11_include" >> Makefile echo "X11_LINK=$x11_link" >> Makefile -# See if we can compile the dbm library - -dbm_include="not found" -dbm_link="not found" -use_gdbm_ndbm=no - -for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do - if test -f $dir/ndbm.h; then - dbm_include=$dir - if sh ./hasgot dbm_open; then - dbm_link="" - elif sh ./hasgot -lndbm dbm_open; then - dbm_link="-lndbm" - elif sh ./hasgot -ldb1 dbm_open; then - dbm_link="-ldb1" - elif sh ./hasgot -lgdbm dbm_open; then - dbm_link="-lgdbm" - elif sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then - dbm_link="-lgdbm_compat -lgdbm" - fi - break - fi - if test -f $dir/gdbm-ndbm.h; then - dbm_include=$dir - use_gdbm_ndbm=yes - if sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then - dbm_link="-lgdbm_compat -lgdbm" - fi - break - fi -done -if test "$dbm_include" = "not found" || test "$dbm_link" = "not found"; then - echo "NDBM not found, the \"dbm\" library will not be supported." -else - echo "NDBM found (in $dbm_include)" - if test "$dbm_include" = "/usr/include"; then - dbm_include="" - else - dbm_include="-I$dbm_include" - fi - if test "$use_gdbm_ndbm" = "yes"; then - echo "#define DBM_USES_GDBM_NDBM" >> s.h - fi - otherlibraries="$otherlibraries dbm" -fi -echo "DBM_INCLUDES=$dbm_include" >> Makefile -echo "DBM_LINK=$dbm_link" >> Makefile - # Look for tcl/tk echo "Configuring LablTk..." @@ -1453,11 +1416,11 @@ if test $tk_wanted = no; then elif test $tk_x11 = no; then has_tk=true elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then - echo "X11 not found." + echo "X11 not found or disabled." has_tk=false else tk_x11_include="$x11_include" - tk_x11_libs="$x11_libs -lX11" + tk_x11_libs="$x11_link" has_tk=true fi @@ -1484,14 +1447,14 @@ 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 - 7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;; - 7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;; - 8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;; - 8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;; - 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; - 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; - 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; 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 ;; + 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; + 8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;; + 8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;; + 7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;; + 7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;; *) echo "This version is not known."; has_tk=false ;; esac else @@ -1537,10 +1500,6 @@ if test $has_tk = true; then fi fi -case "$host" in - *-*-cygwin*) tk_libs="$tk_libs -lws2_32";; -esac - if test $has_tk = true; then if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then echo "Tcl/Tk libraries found." @@ -1591,6 +1550,17 @@ else echo "LIBBFD_LINK=" >> Makefile fi +# Check whether assembler supports CFI directives + +asm_cfi_supported=false + +export aspp + +if sh ./tryassemble cfi.S; then + echo "#define ASM_CFI_SUPPORTED" >> m.h + asm_cfi_supported=true +fi + # Final twiddling of compiler options to work around known bugs nativeccprofopts="$nativecccompopts" @@ -1660,6 +1630,9 @@ echo "CMXS=$cmxs" >> Makefile echo "MKEXE=$mkexe" >> Makefile echo "MKDLL=$mksharedlib" >> Makefile echo "MKMAINDLL=$mkmaindll" >> Makefile +echo "RUNTIMED=${debugruntime}" >>Makefile +echo "CAMLP4=${withcamlp4}" >>Makefile +echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile @@ -1670,7 +1643,7 @@ mv m.h s.h Makefile .. echo echo "** Configuration summary **" echo -echo "Directories where Objective Caml will be installed:" +echo "Directories where OCaml will be installed:" echo " binaries.................. $bindir" echo " standard library.......... $libdir" echo " manual pages.............. $mandir (with extension .$manext)" @@ -1704,6 +1677,11 @@ else echo " options for linking....... $nativecclinkopts $cclibs" echo " assembler ................ $as" echo " preprocessed assembler ... $aspp" + if test "$asm_cfi_supported" = "true"; then + echo " assembler supports CFI ... yes" + else + echo " assembler supports CFI ... no" + fi echo " native dynlink ........... $natdynlink" if test "$profiling" = "prof"; then echo " profiling with gprof ..... supported" @@ -1718,27 +1696,38 @@ else echo "Source-level replay debugger: not supported" fi +if test "$debugruntime" = "runtimed"; then + echo "Debug runtime will be compiled and installed" +fi + echo "Additional libraries supported:" echo " $otherlibraries" echo "Configuration for the \"num\" library:" echo " target architecture ...... $bng_arch (asm level $bng_asm_level)" -if test "$x11_include" != "not found" && test "$x11_lib" != "not found"; then +if $has_graph; then echo "Configuration for the \"graph\" library:" echo " options for compiling .... $x11_include" echo " options for linking ...... $x11_link" +else +echo "The \"graph\" library: not supported" fi if test $has_tk = true; then echo "Configuration for the \"labltk\" library:" echo " use tcl/tk version ....... $tcl_version" -echo " options for compiling .... $tk_defs" -echo " options for linking ...... $tk_libs" +echo " options for compiling .... $tk_defs $x11_includes" +echo " options for linking ...... $tk_libs $x11_link" else echo "The \"labltk\" library: not supported" fi echo -echo "** Objective Caml configuration completed successfully **" +echo "** OCaml configuration completed successfully **" echo + +if test ! -z "$MACOSX_DEPLOYMENT_TARGET"; then + echo "WARNING: the environment variable MACOSX_DEPLOYMENT_TARGET is set." + echo "This will probably prevent compiling the OCaml system." +fi diff --git a/debugger/.cvsignore b/debugger/.cvsignore deleted file mode 100644 index 45440f86..00000000 --- a/debugger/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -lexer.ml -parser.ml -parser.mli -ocamldebug -dynlink.ml -dynlink.mli diff --git a/debugger/.depend b/debugger/.depend index 1a04b1ea..e3c107ab 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -1,46 +1,48 @@ -breakpoints.cmi: primitives.cmi ../bytecomp/instruct.cmi -checkpoints.cmi: primitives.cmi debugcom.cmi -command_line.cmi: -debugcom.cmi: primitives.cmi -debugger_config.cmi: -dynlink.cmi: -envaux.cmi: ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi -eval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ +breakpoints.cmi : primitives.cmi ../bytecomp/instruct.cmi +checkpoints.cmi : primitives.cmi debugcom.cmi +command_line.cmi : +debugcom.cmi : primitives.cmi +debugger_config.cmi : +dynlink.cmi : +envaux.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 -events.cmi: ../bytecomp/instruct.cmi -exec.cmi: -frames.cmi: primitives.cmi ../bytecomp/instruct.cmi -history.cmi: -input_handling.cmi: primitives.cmi -int64ops.cmi: -lexer.cmi: parser.cmi -loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi -parameters.cmi: -parser.cmi: parser_aux.cmi ../parsing/longident.cmi -parser_aux.cmi: primitives.cmi ../parsing/longident.cmi -pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi -pos.cmi: ../bytecomp/instruct.cmi -primitives.cmi: $(UNIXDIR)/unix.cmi -printval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ +events.cmi : ../bytecomp/instruct.cmi +exec.cmi : +frames.cmi : primitives.cmi ../bytecomp/instruct.cmi +history.cmi : +input_handling.cmi : primitives.cmi +int64ops.cmi : +lexer.cmi : parser.cmi +loadprinter.cmi : ../parsing/longident.cmi dynlink.cmi +parameters.cmi : +parser.cmi : parser_aux.cmi ../parsing/longident.cmi +parser_aux.cmi : primitives.cmi ../parsing/longident.cmi +pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi +pos.cmi : ../bytecomp/instruct.cmi +primitives.cmi : $(UNIXDIR)/unix.cmi +printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/env.cmi debugcom.cmi -program_loading.cmi: primitives.cmi -program_management.cmi: -question.cmi: -show_information.cmi: ../bytecomp/instruct.cmi -show_source.cmi: ../bytecomp/instruct.cmi -source.cmi: -symbols.cmi: ../bytecomp/instruct.cmi -time_travel.cmi: primitives.cmi -trap_barrier.cmi: -unix_tools.cmi: $(UNIXDIR)/unix.cmi -breakpoints.cmo: symbols.cmi primitives.cmi pos.cmi ../bytecomp/instruct.cmi \ - exec.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi -breakpoints.cmx: symbols.cmx primitives.cmx pos.cmx ../bytecomp/instruct.cmx \ - exec.cmx debugcom.cmx checkpoints.cmx breakpoints.cmi -checkpoints.cmo: primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi -checkpoints.cmx: primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi -command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ +program_loading.cmi : primitives.cmi +program_management.cmi : +question.cmi : +show_information.cmi : ../bytecomp/instruct.cmi +show_source.cmi : ../bytecomp/instruct.cmi +source.cmi : +symbols.cmi : ../bytecomp/instruct.cmi +time_travel.cmi : primitives.cmi +trap_barrier.cmi : +unix_tools.cmi : $(UNIXDIR)/unix.cmi +breakpoints.cmo : symbols.cmi primitives.cmi pos.cmi \ + ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ + breakpoints.cmi +breakpoints.cmx : symbols.cmx primitives.cmx pos.cmx \ + ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \ + breakpoints.cmi +checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi +checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi +command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \ show_source.cmi show_information.cmi question.cmi program_management.cmi \ program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \ @@ -50,7 +52,7 @@ command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.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 -command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ +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 \ program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \ @@ -60,153 +62,155 @@ command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.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 -debugcom.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \ +debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \ input_handling.cmi debugcom.cmi -debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \ +debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \ input_handling.cmx debugcom.cmi -debugger_config.cmo: int64ops.cmi debugger_config.cmi -debugger_config.cmx: int64ops.cmx debugger_config.cmi -dynlink.cmo: ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ +debugger_config.cmo : int64ops.cmi debugger_config.cmi +debugger_config.cmx : int64ops.cmx debugger_config.cmi +dynlink.cmo : ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \ ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ dynlink.cmi -dynlink.cmx: ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ +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 \ dynlink.cmi -envaux.cmo: ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.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 \ +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 \ +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 \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ frames.cmi ../typing/env.cmi debugcom.cmi ../typing/ctype.cmi \ ../typing/btype.cmi eval.cmi -eval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ +eval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ printval.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ ../typing/path.cmx parser_aux.cmi ../utils/misc.cmx \ ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \ frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \ ../typing/btype.cmx eval.cmi -events.cmo: ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi -events.cmx: ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi -exec.cmo: exec.cmi -exec.cmx: exec.cmi -frames.cmo: symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi events.cmi \ - debugcom.cmi frames.cmi -frames.cmx: symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx events.cmx \ - debugcom.cmx frames.cmi -history.cmo: primitives.cmi int64ops.cmi debugger_config.cmi checkpoints.cmi \ - history.cmi -history.cmx: primitives.cmx int64ops.cmx debugger_config.cmx checkpoints.cmx \ - history.cmi -input_handling.cmo: $(UNIXDIR)/unix.cmi primitives.cmi \ +events.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi +events.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi +exec.cmo : exec.cmi +exec.cmx : exec.cmi +frames.cmo : symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \ + events.cmi debugcom.cmi frames.cmi +frames.cmx : symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \ + events.cmx debugcom.cmx frames.cmi +history.cmo : primitives.cmi int64ops.cmi debugger_config.cmi \ + checkpoints.cmi history.cmi +history.cmx : primitives.cmx int64ops.cmx debugger_config.cmx \ + checkpoints.cmx history.cmi +input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \ input_handling.cmi -input_handling.cmx: $(UNIXDIR)/unix.cmx primitives.cmx \ +input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \ input_handling.cmi -int64ops.cmo: int64ops.cmi -int64ops.cmx: int64ops.cmi -lexer.cmo: parser.cmi lexer.cmi -lexer.cmx: parser.cmx lexer.cmi -loadprinter.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ +int64ops.cmo : int64ops.cmi +int64ops.cmx : int64ops.cmi +lexer.cmo : parser.cmi lexer.cmi +lexer.cmx : parser.cmx lexer.cmi +loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \ dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi -loadprinter.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ +loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \ ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \ dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi -main.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ +main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ show_information.cmi question.cmi program_management.cmi primitives.cmi \ parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \ command_line.cmi ../utils/clflags.cmi checkpoints.cmi -main.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ +main.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ show_information.cmx question.cmx program_management.cmx primitives.cmx \ parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ command_line.cmx ../utils/clflags.cmx checkpoints.cmx -parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \ +parameters.cmo : primitives.cmi envaux.cmi debugger_config.cmi \ ../utils/config.cmi parameters.cmi -parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \ +parameters.cmx : primitives.cmx envaux.cmx debugger_config.cmx \ ../utils/config.cmx parameters.cmi -parser.cmo: parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ +parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ input_handling.cmi parser.cmi -parser.cmx: parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ +parser.cmx : parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ input_handling.cmx parser.cmi -pattern_matching.cmo: ../typing/typedtree.cmi parser_aux.cmi \ +pattern_matching.cmo : ../typing/typedtree.cmi parser_aux.cmi \ ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \ pattern_matching.cmi -pattern_matching.cmx: ../typing/typedtree.cmx parser_aux.cmi \ +pattern_matching.cmx : ../typing/typedtree.cmx parser_aux.cmi \ ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \ pattern_matching.cmi -pos.cmo: source.cmi primitives.cmi ../parsing/location.cmi \ +pos.cmo : source.cmi primitives.cmi ../parsing/location.cmi \ ../bytecomp/instruct.cmi pos.cmi -pos.cmx: source.cmx primitives.cmx ../parsing/location.cmx \ +pos.cmx : source.cmx primitives.cmx ../parsing/location.cmx \ ../bytecomp/instruct.cmx pos.cmi -primitives.cmo: $(UNIXDIR)/unix.cmi primitives.cmi -primitives.cmx: $(UNIXDIR)/unix.cmx primitives.cmi -printval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi \ +primitives.cmo : $(UNIXDIR)/unix.cmi primitives.cmi +primitives.cmx : $(UNIXDIR)/unix.cmx primitives.cmi +printval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi \ ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmi \ ../toplevel/genprintval.cmi debugcom.cmi printval.cmi -printval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx \ +printval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx \ ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmx \ ../toplevel/genprintval.cmx debugcom.cmx printval.cmi -program_loading.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi primitives.cmi \ - parameters.cmi input_handling.cmi debugger_config.cmi program_loading.cmi -program_loading.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx primitives.cmx \ - parameters.cmx input_handling.cmx debugger_config.cmx program_loading.cmi -program_management.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ +program_loading.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ + primitives.cmi parameters.cmi input_handling.cmi debugger_config.cmi \ + program_loading.cmi +program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ + primitives.cmx parameters.cmx input_handling.cmx debugger_config.cmx \ + program_loading.cmi +program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \ debugger_config.cmi breakpoints.cmi program_management.cmi -program_management.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ +program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \ debugger_config.cmx breakpoints.cmx program_management.cmi -question.cmo: primitives.cmi lexer.cmi input_handling.cmi question.cmi -question.cmx: primitives.cmx lexer.cmx input_handling.cmx question.cmi -show_information.cmo: symbols.cmi source.cmi show_source.cmi printval.cmi \ +question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi +question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi +show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \ ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \ debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi -show_information.cmx: symbols.cmx source.cmx show_source.cmx printval.cmx \ +show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \ ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \ debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi -show_source.cmo: source.cmi primitives.cmi parameters.cmi \ +show_source.cmo : source.cmi primitives.cmi parameters.cmi \ ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \ debugger_config.cmi show_source.cmi -show_source.cmx: source.cmx primitives.cmx parameters.cmx \ +show_source.cmx : source.cmx primitives.cmx parameters.cmx \ ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \ debugger_config.cmx show_source.cmi -source.cmo: primitives.cmi ../utils/misc.cmi debugger_config.cmi \ +source.cmo : primitives.cmi ../utils/misc.cmi debugger_config.cmi \ ../utils/config.cmi source.cmi -source.cmx: primitives.cmx ../utils/misc.cmx debugger_config.cmx \ +source.cmx : primitives.cmx ../utils/misc.cmx debugger_config.cmx \ ../utils/config.cmx source.cmi -symbols.cmo: ../bytecomp/symtable.cmi program_loading.cmi \ +symbols.cmo : ../bytecomp/symtable.cmi program_loading.cmi \ ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \ checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi -symbols.cmx: ../bytecomp/symtable.cmx program_loading.cmx \ +symbols.cmx : ../bytecomp/symtable.cmx program_loading.cmx \ ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \ checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi -time_travel.cmo: trap_barrier.cmi symbols.cmi question.cmi \ +time_travel.cmo : trap_barrier.cmi symbols.cmi question.cmi \ program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \ ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \ debugger_config.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ time_travel.cmi -time_travel.cmx: trap_barrier.cmx symbols.cmx question.cmx \ +time_travel.cmx : trap_barrier.cmx symbols.cmx question.cmx \ program_loading.cmx primitives.cmx ../utils/misc.cmx int64ops.cmx \ ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \ debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ time_travel.cmi -trap_barrier.cmo: exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi -trap_barrier.cmx: exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi -unix_tools.cmo: $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ +trap_barrier.cmo : exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi +trap_barrier.cmx : exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi +unix_tools.cmo : $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ unix_tools.cmi -unix_tools.cmx: $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ +unix_tools.cmx : $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ unix_tools.cmi diff --git a/debugger/.ignore b/debugger/.ignore new file mode 100644 index 00000000..45440f86 --- /dev/null +++ b/debugger/.ignore @@ -0,0 +1,6 @@ +lexer.ml +parser.ml +parser.mli +ocamldebug +dynlink.ml +dynlink.mli diff --git a/debugger/Makefile b/debugger/Makefile index 3ff1b54a..2e6534c7 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # diff --git a/debugger/Makefile.nt b/debugger/Makefile.nt index 70263e94..40034ef4 100644 --- a/debugger/Makefile.nt +++ b/debugger/Makefile.nt @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index 778fcf11..820af9af 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -29,9 +29,9 @@ INCLUDES=\ OTHEROBJS=\ $(UNIXDIR)/unix.cma \ - ../utils/misc.cmo ../utils/config.cmo \ - ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \ - ../parsing/longident.cmo \ + ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \ + ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \ + ../parsing/location.cmo ../parsing/longident.cmo \ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ ../typing/subst.cmo ../typing/predef.cmo \ diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index 1da4b74e..5e84cc6c 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli index 091f6099..855ef5e1 100644 --- a/debugger/breakpoints.mli +++ b/debugger/breakpoints.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/checkpoints.ml b/debugger/checkpoints.ml index ffcff35e..e2371f17 100644 --- a/debugger/checkpoints.ml +++ b/debugger/checkpoints.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/checkpoints.mli b/debugger/checkpoints.mli index 17c1037a..b37d1ae5 100644 --- a/debugger/checkpoints.mli +++ b/debugger/checkpoints.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 944efa86..9b0084da 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -230,6 +230,22 @@ let instr_shell ppf lexbuf = if (err != 0) then eprintf "Shell command %S failed with exit code %d\n%!" cmd err +let instr_env ppf lexbuf = + let cmdarg = argument_list_eol argument lexbuf in + let cmdarg = string_trim (String.concat " " cmdarg) in + if cmdarg <> "" then + try + if (String.index cmdarg '=') > 0 then + Debugger_config.environment := cmdarg :: !Debugger_config.environment + else + eprintf "Environment variables should not have an empty name\n%!" + with Not_found -> + eprintf "Environment variables should have the \"name=value\" format\n%!" + else + List.iter + (printf "%s\n%!") + (List.rev !Debugger_config.environment) + let instr_pwd ppf lexbuf = eol lexbuf; fprintf ppf "%s@." (Sys.getcwd ()) @@ -454,7 +470,7 @@ let instr_help ppf lexbuf = 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 *) @@ -962,6 +978,9 @@ With no argument, reset the search path." }; { instr_name = "shell"; instr_prio = false; instr_action = instr_shell; instr_repeat = true; instr_help = "Execute a given COMMAND thru the system shell." }; + { instr_name = "environment"; instr_prio = false; + instr_action = instr_env; instr_repeat = false; instr_help = +"environment variable to give to program being debugged when it is started." }; (* Displacements *) { instr_name = "run"; instr_prio = true; instr_action = instr_run; instr_repeat = true; instr_help = diff --git a/debugger/command_line.mli b/debugger/command_line.mli index dd2349d2..422cf6a2 100644 --- a/debugger/command_line.mli +++ b/debugger/command_line.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index dfe905ba..1da00cba 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -189,8 +189,7 @@ let set_trap_barrier pos = let value_size = if 1 lsl 31 = 0 then 4 else 8 let input_remote_value ic = - let v = String.create value_size in - really_input ic v 0 value_size; v + Misc.input_bytes ic value_size let output_remote_value ic v = output ic v 0 value_size @@ -247,8 +246,7 @@ module Remote_value = if input_byte !conn.io_in = 0 then Remote(input_remote_value !conn.io_in) else begin - let buf = String.create 8 in - really_input !conn.io_in buf 0 8; + let buf = Misc.input_bytes !conn.io_in 8 in let floatbuf = float n (* force allocation of a new float *) in String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; Local(Obj.repr floatbuf) diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli index abf4fd0b..7d107ac5 100644 --- a/debugger/debugcom.mli +++ b/debugger/debugcom.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index 54d6b2d5..29287593 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -56,7 +56,7 @@ let shell = "Win32" -> "cmd" | _ -> "/bin/sh" -(* Name of the Objective Caml runtime. *) +(* Name of the OCaml runtime. *) let runtime_program = "ocamlrun" (* Time history size (for `last') *) @@ -80,3 +80,7 @@ let make_checkpoints = ref (match Sys.os_type with "Win32" -> false | _ -> true) + +(*** Environment variables for debugee. ***) + +let environment = ref [] diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index 18faf9c6..d3f1a2a7 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -33,3 +33,7 @@ val checkpoint_big_step : int64 ref val checkpoint_small_step : int64 ref val checkpoint_max_count : int ref val make_checkpoints : bool ref + +(*** Environment variables for debugee. ***) + +val environment : string list ref diff --git a/debugger/envaux.ml b/debugger/envaux.ml index 8d462e2f..56786929 100644 --- a/debugger/envaux.ml +++ b/debugger/envaux.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/envaux.mli b/debugger/envaux.mli index 8b122cc3..b78173c4 100644 --- a/debugger/envaux.mli +++ b/debugger/envaux.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/eval.ml b/debugger/eval.ml index 7ee1339f..0f8c8a05 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/eval.mli b/debugger/eval.mli index b2a2998f..96661b2a 100644 --- a/debugger/eval.mli +++ b/debugger/eval.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/events.ml b/debugger/events.ml index 2521c064..78733bfc 100644 --- a/debugger/events.ml +++ b/debugger/events.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/events.mli b/debugger/events.mli index 7166f2c9..f795058c 100644 --- a/debugger/events.mli +++ b/debugger/events.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/exec.ml b/debugger/exec.ml index 1ea16597..22d281bc 100644 --- a/debugger/exec.ml +++ b/debugger/exec.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/exec.mli b/debugger/exec.mli index 9d3b9860..c9d665ae 100644 --- a/debugger/exec.mli +++ b/debugger/exec.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/frames.ml b/debugger/frames.ml index c533782f..2a87ffdd 100644 --- a/debugger/frames.ml +++ b/debugger/frames.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/frames.mli b/debugger/frames.mli index b4863433..5023236c 100644 --- a/debugger/frames.mli +++ b/debugger/frames.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/history.ml b/debugger/history.ml index e8c5ed8f..473ba80b 100644 --- a/debugger/history.ml +++ b/debugger/history.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/history.mli b/debugger/history.mli index 249629fd..542b9ca0 100644 --- a/debugger/history.mli +++ b/debugger/history.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml index f25d4742..8bbc0d80 100644 --- a/debugger/input_handling.ml +++ b/debugger/input_handling.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli index 959547df..7ae190ee 100644 --- a/debugger/input_handling.mli +++ b/debugger/input_handling.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml index b854a6c3..a3dbdbe2 100644 --- a/debugger/int64ops.ml +++ b/debugger/int64ops.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocqencourt *) (* *) diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli index 98f7228d..f898f143 100644 --- a/debugger/int64ops.mli +++ b/debugger/int64ops.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocqencourt *) (* *) diff --git a/debugger/lexer.mli b/debugger/lexer.mli index 7214ed2b..23f88e57 100644 --- a/debugger/lexer.mli +++ b/debugger/lexer.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/lexer.mll b/debugger/lexer.mll index eea8ed02..7dd51e70 100644 --- a/debugger/lexer.mll +++ b/debugger/lexer.mll @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index ac5aa018..0395cfb3 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -106,7 +106,7 @@ let match_printer_type desc typename = let ty_arg = Ctype.newvar() in Ctype.unify Env.empty (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance desc.val_type); + (Ctype.instance Env.empty desc.val_type); Ctype.end_def(); Ctype.generalize ty_arg; ty_arg diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli index bdaf77a2..77edfc53 100644 --- a/debugger/loadprinter.mli +++ b/debugger/loadprinter.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/debugger/main.ml b/debugger/main.ml index f5f0d8b5..9dbb41ee 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -158,7 +158,7 @@ let set_checkpoints n = let set_directory dir = Sys.chdir dir let print_version () = - printf "The Objective Caml debugger, version %s@." Sys.ocaml_version; + printf "The OCaml debugger, version %s@." Sys.ocaml_version; exit 0; ;; let print_version_num () = @@ -183,7 +183,11 @@ let speclist = [ " Print version number and exit"; ] +let function_placeholder () = + raise Not_found + let main () = + Callback.register "Debugger.function_placeholder" function_placeholder; try socket_name := (match Sys.os_type with @@ -206,7 +210,7 @@ let main () = arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j)) done end; - printf "\tObjective Caml Debugger version %s@.@." Config.version; + printf "\tOCaml Debugger version %s@.@." Config.version; Config.load_path := !default_load_path; Clflags.recursive_types := true; (* Allow recursive types. *) toplevel_loop (); (* Toplevel. *) diff --git a/debugger/parameters.ml b/debugger/parameters.ml index 9d518e54..fb816e4d 100644 --- a/debugger/parameters.ml +++ b/debugger/parameters.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/parameters.mli b/debugger/parameters.mli index 8f750e68..eb055f7c 100644 --- a/debugger/parameters.mli +++ b/debugger/parameters.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/parser.mly b/debugger/parser.mly index 6fc8392a..5bba611b 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -1,9 +1,9 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Jerome Vouillon, projet Cristal, INRIA Rocquencourt */ -/* Objective Caml port by John Malecki and Xavier Leroy */ +/* 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 */ @@ -170,6 +170,8 @@ longident : LIDENT { Lident $1 } | module_path DOT LIDENT { Ldot($1, $3) } | OPERATOR { Lident $1 } + | module_path DOT OPERATOR { Ldot($1, $3) } + | module_path DOT LPAREN OPERATOR RPAREN { Ldot($1, $4) } ; module_path : diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli index a68e08d5..275281cc 100644 --- a/debugger/parser_aux.mli +++ b/debugger/parser_aux.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml index 97af9326..b9211826 100644 --- a/debugger/pattern_matching.ml +++ b/debugger/pattern_matching.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/pattern_matching.mli b/debugger/pattern_matching.mli index 3490edef..a7a52562 100644 --- a/debugger/pattern_matching.mli +++ b/debugger/pattern_matching.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/pos.ml b/debugger/pos.ml index 4beba3de..99516864 100644 --- a/debugger/pos.ml +++ b/debugger/pos.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) @@ -20,23 +20,8 @@ open Source;; let get_desc ev = let loc = ev.ev_loc in - if loc.loc_start.pos_fname <> "" - then Printf.sprintf "file %s, line %d, characters %d-%d" - loc.loc_start.pos_fname loc.loc_start.pos_lnum - (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1) - (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1) - else begin - let filename = source_of_module ev.ev_loc.loc_start ev.ev_module in - try - let (start, line) = line_of_pos (get_buffer loc.loc_start ev.ev_module) - loc.loc_start.pos_cnum - in - Printf.sprintf "file %s, line %d, characters %d-%d" - filename line (loc.loc_start.pos_cnum - start + 1) - (loc.loc_end.pos_cnum - start + 1) - with Not_found | Out_of_range -> - Printf.sprintf "file %s, characters %d-%d" - filename (loc.loc_start.pos_cnum + 1) - (loc.loc_end.pos_cnum + 1) - end + Printf.sprintf "file %s, line %d, characters %d-%d" + loc.loc_start.pos_fname loc.loc_start.pos_lnum + (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1) + (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1) ;; diff --git a/debugger/pos.mli b/debugger/pos.mli index e7632e42..a4c8e9e8 100644 --- a/debugger/pos.mli +++ b/debugger/pos.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/debugger/primitives.ml b/debugger/primitives.ml index d4ba22e5..bfd2fdd8 100644 --- a/debugger/primitives.ml +++ b/debugger/primitives.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/primitives.mli b/debugger/primitives.mli index 4333128f..4d914da9 100644 --- a/debugger/primitives.mli +++ b/debugger/primitives.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/printval.ml b/debugger/printval.ml index 5f36e1a7..84a0f06e 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/printval.mli b/debugger/printval.mli index bb631888..f1c4569b 100644 --- a/debugger/printval.mli +++ b/debugger/printval.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index 79577ff4..bef9f80d 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -35,6 +35,39 @@ let load_program () = (*** Launching functions. ***) +(* Returns the environment to be passed to debugee *) +let get_environment () = + let env = Unix.environment () in + let have_same_name x y = + let split = Primitives.split_string '=' in + match split x, split y with + (hd1 :: _), (hd2 :: _) -> hd1 = hd2 + | _ -> false in + let have_name_in_config_env x = + List.exists + (have_same_name x) + !Debugger_config.environment in + let env = + Array.fold_right + (fun elem acc -> + if have_name_in_config_env elem then + acc + else + elem :: acc) + env + [] in + Array.of_list (env @ !Debugger_config.environment) + +(* Returns the environment to be passed to debugee *) +let get_win32_environment () = + let res = Buffer.create 256 in + let env = get_environment () in + let len = Array.length env in + for i = 0 to pred len do + Buffer.add_string res (Printf.sprintf "set %s && " env.(i)) + done; + Buffer.contents res + (* A generic function for launching the program *) let generic_exec_unix cmdline = function () -> if !debug_loading then @@ -52,7 +85,7 @@ let generic_exec_unix cmdline = function () -> 0 -> (* Try to detach the process from the controlling terminal, so that it does not receive SIGINT on ctrl-C. *) begin try ignore(setsid()) with Invalid_argument _ -> () end; - execv shell [| shell; "-c"; cmdline() |] + execve shell [| shell; "-c"; cmdline() |] (get_environment ()) | _ -> exit 0 with x -> Unix_tools.report_error x; @@ -76,7 +109,7 @@ let generic_exec = "Win32" -> generic_exec_win | _ -> generic_exec_unix -(* Execute the program by calling the runtime explicitely *) +(* Execute the program by calling the runtime explicitly *) let exec_with_runtime = generic_exec (function () -> @@ -86,7 +119,8 @@ let exec_with_runtime = but quoting is even worse because Unix.create_process thinks each command line parameter is a file. So no good solution so far *) - Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s %s" + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s %s" + (get_win32_environment ()) !socket_name runtime_program !program_name @@ -105,7 +139,8 @@ let exec_direct = match Sys.os_type with "Win32" -> (* See the comment above *) - Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s" + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s" + (get_win32_environment ()) !socket_name !program_name !arguments diff --git a/debugger/program_loading.mli b/debugger/program_loading.mli index d1210d1a..2814eb39 100644 --- a/debugger/program_loading.mli +++ b/debugger/program_loading.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 8ebb907d..3e6ffa81 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/program_management.mli b/debugger/program_management.mli index 8e2f28e5..96f5a438 100644 --- a/debugger/program_management.mli +++ b/debugger/program_management.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/question.ml b/debugger/question.ml index 2eeec3ab..f17227b9 100644 --- a/debugger/question.ml +++ b/debugger/question.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Pouillard, projet Gallium, 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 Input_handling open Primitives diff --git a/debugger/question.mli b/debugger/question.mli index 3a92dee6..d8e50ef9 100644 --- a/debugger/question.mli +++ b/debugger/question.mli @@ -1,2 +1,14 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Pouillard, projet Gallium, 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. *) +(* *) +(***********************************************************************) + (* Ask user a yes or no question. *) val yes_or_no : string -> bool diff --git a/debugger/show_information.ml b/debugger/show_information.ml index bd746eb7..86e9637a 100644 --- a/debugger/show_information.ml +++ b/debugger/show_information.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/show_information.mli b/debugger/show_information.mli index 3069f933..7774721a 100644 --- a/debugger/show_information.mli +++ b/debugger/show_information.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/show_source.ml b/debugger/show_source.ml index 2826c9e6..4a998f52 100644 --- a/debugger/show_source.ml +++ b/debugger/show_source.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/show_source.mli b/debugger/show_source.mli index 5ba418af..3b136ab7 100644 --- a/debugger/show_source.mli +++ b/debugger/show_source.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/source.ml b/debugger/source.ml index f0d3d48f..0f705f25 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) @@ -39,20 +39,7 @@ let source_of_module pos mdle = Debugger_config.load_path_for !Config.load_path in let fname = pos.Lexing.pos_fname in - if fname = "" then - let innermost_module = - try - let dot_index = String.rindex mdle '.' in - String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index)) - with Not_found -> mdle in - let rec loop = - function - | [] -> raise Not_found - | ext :: exts -> - try find_in_path_uncap path (innermost_module ^ ext) - with Not_found -> loop exts - in loop source_extensions - else if Filename.is_implicit fname then + if Filename.is_implicit fname then find_in_path path fname else fname @@ -76,13 +63,11 @@ let get_buffer pos mdle = try List.assoc mdle !buffer_list with Not_found -> let inchan = open_in_bin (source_of_module pos mdle) in - let (content, _) as buffer = - (String.create (in_channel_length inchan), ref []) - in - unsafe_really_input inchan content 0 (in_channel_length inchan); - buffer_list := - (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); - buffer + let content = Misc.input_bytes inchan (in_channel_length inchan) in + let buffer = (content, ref []) in + buffer_list := + (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); + buffer let buffer_content = (fst : buffer -> string) diff --git a/debugger/source.mli b/debugger/source.mli index 273cb517..50fa3f02 100644 --- a/debugger/source.mli +++ b/debugger/source.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 392da976..9fba3e09 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/symbols.mli b/debugger/symbols.mli index 57ac8007..8823abd2 100644 --- a/debugger/symbols.mli +++ b/debugger/symbols.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index a4a4c83f..e10e0396 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli index 453e4df0..dad47fed 100644 --- a/debugger/time_travel.mli +++ b/debugger/time_travel.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml index dba9c929..6aa22b26 100644 --- a/debugger/trap_barrier.ml +++ b/debugger/trap_barrier.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/trap_barrier.mli b/debugger/trap_barrier.mli index 28bba5a3..b12391af 100644 --- a/debugger/trap_barrier.mli +++ b/debugger/trap_barrier.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index 9926e05d..dea47f99 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/debugger/unix_tools.mli b/debugger/unix_tools.mli index b5e4ee6c..bbea8447 100644 --- a/debugger/unix_tools.mli +++ b/debugger/unix_tools.mli @@ -1,9 +1,9 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) +(* 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 *) diff --git a/driver/compile.ml b/driver/compile.ml index 4e2d8566..cf9c2a4a 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -116,9 +116,13 @@ let implementation ppf sourcefile outputprefix = 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) + ++ Typemod.type_implementation sourcefile outputprefix modulename env); + Warnings.check_fatal (); + Pparse.remove_preprocessed inputfile; + Stypes.dump (outputprefix ^ ".annot"); with x -> Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (outputprefix ^ ".annot"); raise x end else begin let objfile = outputprefix ^ ".cmo" in @@ -126,7 +130,6 @@ let implementation ppf sourcefile outputprefix = try Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Unused_var.warn ppf ++ Typemod.type_implementation sourcefile outputprefix modulename env ++ Translmod.transl_implementation modulename ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda diff --git a/driver/compile.mli b/driver/compile.mli index 507d61bb..779239a8 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/driver/errors.ml b/driver/errors.ml index 22dd1fc6..9400e9eb 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/driver/errors.mli b/driver/errors.mli index ac203a53..9f7020d0 100644 --- a/driver/errors.mli +++ b/driver/errors.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/driver/main.ml b/driver/main.ml index 09aa8965..94b024ea 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -61,7 +61,7 @@ let process_file ppf name = raise(Arg.Bad("don't know what to do with " ^ name)) let print_version_and_library () = - print_string "The Objective Caml compiler, version "; + print_string "The OCaml compiler, version "; print_string Config.version; print_newline(); print_string "Standard library directory: "; print_string Config.standard_library; print_newline(); @@ -75,10 +75,12 @@ let print_standard_library () = let usage = "Usage: ocamlc \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 = process_file ppf;; +let impl = process_implementation_file ppf;; +let intf = process_interface_file ppf;; let show_config () = Config.print_config stdout; @@ -89,6 +91,7 @@ module Options = Main_args.Make_bytecomp_options (struct let set r () = r := true let unset r () = r := false let _a = set make_archive + let _absname = set Location.absname let _annot = set annotations let _c = set compile_only let _cc s = c_compiler := Some s @@ -119,6 +122,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _pp s = preprocessor := Some s let _principal = set principal let _rectypes = set recursive_types + let _runtime_variant s = runtime_variant := s let _strict_sequence = set strict_sequence let _thread = set use_threads let _vmthread = set use_vmthreads @@ -165,16 +169,19 @@ let main () = fatal "Option -i is incompatible with -pack, -a, -output-obj" else fatal "Please specify at most one of -pack, -a, -c, -output-obj"; - if !make_archive then begin Compile.init_path(); - Bytelibrarian.create_archive (List.rev !objfiles) - (extract_output !output_name) + + Bytelibrarian.create_archive ppf (List.rev !objfiles) + (extract_output !output_name); + Warnings.check_fatal (); end else if !make_package then begin Compile.init_path(); - Bytepackager.package_files (List.rev !objfiles) - (extract_output !output_name) + let extracted_output = extract_output !output_name in + let revd = List.rev !objfiles in + Bytepackager.package_files ppf revd (extracted_output); + Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin let target = @@ -194,11 +201,12 @@ let main () = default_output !output_name in Compile.init_path(); - Bytelink.link (List.rev !objfiles) target + Bytelink.link ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end; exit 0 with x -> - Errors.report_error Format.err_formatter x; + Errors.report_error ppf x; exit 2 let _ = main () diff --git a/driver/main.mli b/driver/main.mli index d175a3ca..b949bb0f 100644 --- a/driver/main.mli +++ b/driver/main.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/driver/main_args.ml b/driver/main_args.ml index 279a4632..75e3f164 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) @@ -16,6 +16,10 @@ 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" +;; + let mk_annot f = "-annot", Arg.Unit f, " Save information in .annot" ;; @@ -165,6 +169,11 @@ let mk_noprompt f = "-noprompt", Arg.Unit f, " Suppress all prompts" ;; +let mk_nopromptcont f = + "-nopromptcont", Arg.Unit f, + " Suppress prompts for continuation lines of multi-line inputs" +;; + let mk_nostdlib f = "-nostdlib", Arg.Unit f, " Do not add default directory to the list of include directories" @@ -204,10 +213,19 @@ let mk_rectypes f = "-rectypes", Arg.Unit f, " Allow arbitrary recursive types" ;; +let mk_runtime_variant f = + "-runtime-variant", Arg.String f, + " Use the variant of the run-time system" +;; + let mk_S f = "-S", Arg.Unit f, " Keep intermediate assembly file" ;; +let mk_stdin f = + "-stdin", Arg.Unit f, " Read script from standard input" +;; + let mk_strict_sequence f = "-strict-sequence", Arg.Unit f, " Left-hand part of a sequence must have type unit" @@ -310,6 +328,10 @@ let mk_dlambda f = "-dlambda", Arg.Unit f, " (undocumented)" ;; +let mk_dclambda f = + "-dclambda", Arg.Unit f, " (undocumented)" +;; + let mk_dinstr f = "-dinstr", Arg.Unit f, " (undocumented)" ;; @@ -373,6 +395,7 @@ let mk__ f = module type Bytecomp_options = sig val _a : unit -> unit + val _absname : unit -> unit val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit @@ -402,6 +425,7 @@ module type Bytecomp_options = sig val _pp : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _runtime_variant : string -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit @@ -427,6 +451,7 @@ module type Bytecomp_options = sig end;; module type Bytetop_options = sig + val _absname : unit -> unit val _I : string -> unit val _init : string -> unit val _labels : unit -> unit @@ -434,9 +459,11 @@ module type Bytetop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _stdin: unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit @@ -455,6 +482,7 @@ end;; module type Optcomp_options = sig val _a : unit -> unit + val _absname : unit -> unit val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit @@ -485,9 +513,10 @@ module type Optcomp_options = sig val _pp : 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 _S : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit @@ -503,6 +532,7 @@ module type Optcomp_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit @@ -521,6 +551,7 @@ module type Optcomp_options = sig end;; module type Opttop_options = sig + val _absname : unit -> unit val _compact : unit -> unit val _I : string -> unit val _init : string -> unit @@ -530,11 +561,13 @@ module type Opttop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit - val _strict_sequence : unit -> unit val _S : unit -> unit + val _stdin : unit -> unit + val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit @@ -545,6 +578,7 @@ module type Opttop_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit @@ -570,6 +604,7 @@ module Make_bytecomp_options (F : Bytecomp_options) = struct let list = [ mk_a F._a; + mk_absname F._absname; mk_annot F._annot; mk_c F._c; mk_cc F._cc; @@ -604,6 +639,7 @@ struct mk_pp F._pp; mk_principal F._principal; mk_rectypes F._rectypes; + mk_runtime_variant F._runtime_variant; mk_strict_sequence F._strict_sequence; mk_thread F._thread; mk_unsafe F._unsafe; @@ -633,6 +669,7 @@ end;; module Make_bytetop_options (F : Bytetop_options) = struct let list = [ + mk_absname F._absname; mk_I F._I; mk_init F._init; mk_labels F._labels; @@ -640,9 +677,11 @@ struct mk_noassert F._noassert; mk_nolabels F._nolabels; mk_noprompt F._noprompt; + mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; mk_principal F._principal; mk_rectypes F._rectypes; + mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; mk_version F._version; @@ -664,6 +703,7 @@ module Make_optcomp_options (F : Optcomp_options) = struct let list = [ mk_a F._a; + mk_absname F._absname; mk_annot F._annot; mk_c F._c; mk_cc F._cc; @@ -695,6 +735,7 @@ struct mk_pp F._pp; 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; @@ -713,11 +754,13 @@ struct mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; + mk_dclambda F._dclambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dsplit; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; @@ -732,6 +775,7 @@ end;; module Make_opttop_options (F : Opttop_options) = struct let list = [ + mk_absname F._absname; mk_compact F._compact; mk_I F._I; mk_init F._init; @@ -741,10 +785,12 @@ module Make_opttop_options (F : Opttop_options) = struct mk_noassert F._noassert; mk_nolabels F._nolabels; mk_noprompt F._noprompt; + mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; mk_principal F._principal; mk_rectypes F._rectypes; mk_S F._S; + mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; mk_version F._version; @@ -755,11 +801,13 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; + mk_dclambda F._dclambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dsplit; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; diff --git a/driver/main_args.mli b/driver/main_args.mli index 1c4abf50..4c9eacca 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) @@ -15,6 +15,7 @@ module type Bytecomp_options = sig val _a : unit -> unit + val _absname : unit -> unit val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit @@ -44,6 +45,7 @@ module type Bytecomp_options = val _pp : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _runtime_variant : string -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit @@ -70,6 +72,7 @@ module type Bytecomp_options = ;; module type Bytetop_options = sig + val _absname : unit -> unit val _I : string -> unit val _init : string -> unit val _labels : unit -> unit @@ -77,9 +80,11 @@ module type Bytetop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit @@ -98,6 +103,7 @@ end;; module type Optcomp_options = sig val _a : unit -> unit + val _absname : unit -> unit val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit @@ -128,9 +134,10 @@ module type Optcomp_options = sig val _pp : 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 _S : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit @@ -146,6 +153,7 @@ module type Optcomp_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit @@ -164,6 +172,7 @@ module type Optcomp_options = sig end;; module type Opttop_options = sig + val _absname : unit -> unit val _compact : unit -> unit val _I : string -> unit val _init : string -> unit @@ -173,11 +182,13 @@ module type Opttop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit - val _strict_sequence : unit -> unit val _S : unit -> unit + val _stdin : unit -> unit + val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit @@ -188,6 +199,7 @@ module type Opttop_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit diff --git a/driver/ocamlcomp.sh.in b/driver/ocamlcomp.sh.in index 2aeb2de2..fc0a8e11 100644 --- a/driver/ocamlcomp.sh.in +++ b/driver/ocamlcomp.sh.in @@ -1,5 +1,17 @@ #!/bin/sh +######################################################################### +# # +# OCaml # +# # +# Jacques Garrigue, Kyoto University RIMS # +# # +# 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. # +# # +######################################################################### + topdir=`dirname $0` exec @compiler@ -nostdlib -I $topdir/stdlib "$@" diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 29afc628..1e6ab0ce 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -119,12 +119,10 @@ let implementation ppf sourcefile outputprefix = if !Clflags.print_types then ignore( Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Unused_var.warn ppf ++ Typemod.type_implementation sourcefile outputprefix modulename env) else begin Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Unused_var.warn ppf ++ Typemod.type_implementation sourcefile outputprefix modulename env ++ Translmod.transl_store_implementation modulename +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 507d61bb..779239a8 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 58178199..f931990a 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/driver/opterrors.mli b/driver/opterrors.mli index d09dc733..94966741 100644 --- a/driver/opterrors.mli +++ b/driver/opterrors.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/driver/optmain.ml b/driver/optmain.ml index 1c7352c5..87f4c75f 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -30,6 +30,8 @@ let process_implementation_file ppf name = Optcompile.implementation ppf name opref; objfiles := (opref ^ ".cmx") :: !objfiles +let cmxa_present = ref false;; + let process_file ppf name = if Filename.check_suffix name ".ml" || Filename.check_suffix name ".mlt" then @@ -39,10 +41,12 @@ let process_file ppf name = Optcompile.interface ppf name opref; if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles end - else if Filename.check_suffix name ".cmx" - || Filename.check_suffix name ".cmxa" then + else if Filename.check_suffix name ".cmx" then + objfiles := name :: !objfiles + else if Filename.check_suffix name ".cmxa" then begin + cmxa_present := true; objfiles := name :: !objfiles - else if Filename.check_suffix name ".cmi" && !make_package then + end else if Filename.check_suffix name ".cmi" && !make_package then objfiles := name :: !objfiles else if Filename.check_suffix name ext_obj || Filename.check_suffix name ext_lib then @@ -56,7 +60,7 @@ let process_file ppf name = raise(Arg.Bad("don't know what to do with " ^ name)) let print_version_and_library () = - print_string "The Objective Caml native-code compiler, version "; + 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(); @@ -98,6 +102,7 @@ module Options = Main_args.Make_optcomp_options (struct let clear r () = r := false let _a = set make_archive + let _absname = set Location.absname let _annot = set annotations let _c = set compile_only let _cc s = c_compiler := Some s @@ -128,6 +133,7 @@ module Options = Main_args.Make_optcomp_options (struct let _pp s = preprocessor := Some s let _principal = set principal let _rectypes = set recursive_types + let _runtime_variant s = runtime_variant := s let _strict_sequence = set strict_sequence let _shared () = shared := true; dlcode := true let _S = set keep_asm_file @@ -146,6 +152,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dparsetree = set dump_parsetree 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 @@ -175,19 +182,24 @@ let main () = then fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj"; if !make_archive then begin + if !cmxa_present then + fatal "Option -a cannot be used with .cmxa input files."; Optcompile.init_path(); let target = extract_output !output_name in Asmlibrarian.create_archive (List.rev !objfiles) target; + Warnings.check_fatal (); end else if !make_package then begin Optcompile.init_path(); let target = extract_output !output_name in Asmpackager.package_files ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end else if !shared then begin Optcompile.init_path(); let target = extract_output !output_name in Asmlink.link_shared ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin let target = @@ -206,7 +218,8 @@ let main () = default_output !output_name in Optcompile.init_path(); - Asmlink.link ppf (List.rev !objfiles) target + Asmlink.link ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end; exit 0 with x -> diff --git a/driver/optmain.mli b/driver/optmain.mli index 628d2d39..701508af 100644 --- a/driver/optmain.mli +++ b/driver/optmain.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/driver/pparse.ml b/driver/pparse.ml index 0622ddad..dae174ce 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) @@ -51,15 +51,14 @@ let file ppf inputfile parse_fun ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); + 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 -> - Misc.fatal_error "Ocaml and preprocessor have incompatible versions" + Misc.fatal_error "OCaml and preprocessor have incompatible versions" | _ -> false in let ast = diff --git a/driver/pparse.mli b/driver/pparse.mli index 0ed03913..96c2594f 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/emacs/.cvsignore b/emacs/.cvsignore deleted file mode 100644 index ea6381f9..00000000 --- a/emacs/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -ocamltags diff --git a/emacs/.ignore b/emacs/.ignore new file mode 100644 index 00000000..ea6381f9 --- /dev/null +++ b/emacs/.ignore @@ -0,0 +1 @@ +ocamltags diff --git a/emacs/Makefile b/emacs/Makefile index 077770c6..6475be90 100644 --- a/emacs/Makefile +++ b/emacs/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -41,14 +41,17 @@ COMPILECMD=(progn \ install: @if test "$(EMACSDIR)" = ""; then \ + $(EMACS) --batch --eval 't; see PR#5403'; \ set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \ - 2>/dev/null | \ - sed -n -e '/\/site-lisp/s/"//gp'`; \ - if test "$$2" = ""; then \ - echo "Cannot determine Emacs site-lisp directory"; \ - exit 2; \ - fi; \ + 2>/dev/null | \ + sed -n -e 's/^"\(.*\/site-lisp\).*/\1/gp' | \ + sort -u`; \ + if test "$$2" = "" -o "$$3" != ""; then \ + echo "Cannot determine Emacs site-lisp directory:"; \ + shift; while test "$$1" != ""; do echo "\t$$1"; shift; done; \ + else \ $(MAKE) EMACSDIR="$$2" simple-install; \ + fi; \ else \ $(MAKE) simple-install; \ fi diff --git a/emacs/README b/emacs/README index a1e4782a..9c30c889 100644 --- a/emacs/README +++ b/emacs/README @@ -1,7 +1,7 @@ - O'Caml emacs mode, snapshot of $Date: 2008-01-11 17:13:18 +0100 (Fri, 11 Jan 2008) $ + OCaml emacs mode, snapshot of $Date$ The files in this archive define a caml-mode for emacs, for editing -Objective Caml and Objective Label programs, as well as an +OCaml and Objective Label programs, as well as an inferior-caml-mode, to run a toplevel. Caml-mode supports indentation, compilation and error retrieving, @@ -12,17 +12,20 @@ This package is based on the original caml-mode for caml-light by Xavier Leroy, extended with indentation by Ian Zimmerman. For details see README.itz, which is the README from Ian Zimmerman's package. -To use it, just put the .el files in your path, and add the following -three lines in your .emacs. +To use it, just put the .el files in your emacs load path, and add the +following lines in your .emacs. - (setq auto-mode-alist - (cons '("\\.ml[iylp]?$" . caml-mode) auto-mode-alist)) - (autoload 'caml-mode "caml" "Major mode for editing Caml code." t) - (autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) + (add-to-list 'auto-mode-alist '("\\.ml[iylp]?$" . caml-mode)) + (autoload 'caml-mode "caml" "Major mode for editing OCaml code." t) + (autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t) + (autoload 'camldebug "camldebug" "Run ocamldebug on program." t) + (add-to-list 'interpreter-mode-alist '("ocamlrun" . caml-mode)) + (add-to-list 'interpreter-mode-alist '("ocaml" . caml-mode)) -I added camldebug.el from the original distribution, since there will -soon be a debugger for Objective Caml, but I do not know enough about -it. +or put the .el files in, eg. "/usr/share/emacs/site-lisp/caml-mode/" +and add the following line in addtion to the four lines above: + + (add-to-list 'load-path "/usr/share/emacs/site-lisp/caml-mode") To install the mode itself, edit the Makefile and do @@ -120,7 +123,7 @@ Version 1.07: Version 1.06: ------------ -* new keywords in O'Caml 1.06 +* new keywords in Objective Caml 1.06 * compatibility with GNU Emacs 20 @@ -150,7 +153,7 @@ Version 1.03b: (setq caml-quote-char "`") (setq inferior-caml-program "camllight") Literals will be correctly understood and highlighted. However, - indentation rules are still Objective Caml's: this just happens to + indentation rules are still OCaml's: this just happens to work well in most cases, but is only intended for occasional use. * as many people asked for it, application is now indented. This seems @@ -164,10 +167,10 @@ Version 1.03b: Version 1.03: ------------ -* support of Objective Caml and Objective Label. +* support of OCaml and Objective Label. * an indentation very close to mine, which happens to be the same as - Xavier's, since the sources of the Objective Caml compiler do not + Xavier's, since the sources of the OCaml compiler do not change if you indent them in this mode. * highlighting. @@ -175,7 +178,7 @@ Version 1.03: Some remarks about the style supported: -------------------------------------- -Since Objective Caml's syntax is very liberal (more than 100 +Since OCaml's syntax is very liberal (more than 100 shift-reduce conflicts with yacc), automatic indentation is far from easy. Moreover, you expect the indentation to be not purely syntactic, but also semantic: reflecting the meaning of your program. diff --git a/emacs/README.itz b/emacs/README.itz index 8e1366f4..7bcc7aa0 100644 --- a/emacs/README.itz +++ b/emacs/README.itz @@ -1,7 +1,7 @@ DESCRIPTION: -This directory contains files to help editing Caml code, running a -Caml toplevel, and running the Caml debugger under the Gnu Emacs editor. +This directory contains files to help editing OCaml code, running a +OCaml toplevel, and running the OCaml debugger under the Gnu Emacs editor. AUTHORS: @@ -13,10 +13,10 @@ camldebug.el is derived from FSF code. CONTENTS: - caml.el A major mode for editing Caml code in Gnu Emacs - inf-caml.el To run a Caml toplevel under Emacs, with input and + caml.el A major mode for editing OCaml code in Gnu Emacs + inf-caml.el To run a OCaml toplevel under Emacs, with input and output in an Emacs buffer. - camldebug.el To run the Caml debugger under Emacs. + camldebug.el To run the OCaml debugger under Emacs. NOTE FOR EMACS 18 USERS: @@ -29,13 +29,13 @@ USAGE: Add the following lines to your .emacs file: (setq auto-mode-alist (cons '("\\.ml[iylp]?" . caml-mode) auto-mode-alist)) -(autoload 'caml-mode "caml" "Major mode for editing Caml code." t) -(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) -(autoload 'camldebug "camldebug" "Run the Caml debugger." t) +(autoload 'caml-mode "caml" "Major mode for editing OCaml code." t) +(autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t) +(autoload 'camldebug "camldebug" "Run the OCaml debugger." t) The Caml major mode is triggered by visiting a file with extension .ml, .mli, .mly. .mll or .mlp, or manually by M-x caml-mode. It gives you the -correct syntax table for the Caml language. For a brief description of +correct syntax table for the OCaml language. For a brief description of the indentation capabilities, see below under NEWS. The Caml mode also allows you to run batch Caml compilations from @@ -44,16 +44,16 @@ sets the point at the beginning of the erroneous program fragment, and the mark at the end. Under Emacs 19, the program fragment is temporarily highlighted. -M-x run-caml starts a Caml toplevel with input and output in an Emacs +M-x run-caml starts an OCaml toplevel with input and output in an Emacs buffer named *inferior-caml*. This gives you the full power of Emacs -to edit the input to the Caml toplevel. This mode is based on comint +to edit the input to the OCaml toplevel. This mode is based on comint so you get all the usual comint features, including command history. After M-x run-caml, typing C-c C-e or M-C-x in a buffer in Caml mode -sends the current phrase (containing the point) to the Caml toplevel, +sends the current phrase (containing the point) to the OCaml toplevel, and evaluates it. -M-x camldebug FILE starts the Caml debugger camldebug on the executable +M-x camldebug FILE starts the OCaml debugger camldebug on the executable FILE, with input and output in an Emacs buffer named *camldebug-FILE*. For a brief description of the commands available in this buffer, see NEWS below. diff --git a/emacs/caml-compat.el b/emacs/caml-compat.el index 8ba7a99c..da54cd0d 100644 --- a/emacs/caml-compat.el +++ b/emacs/caml-compat.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) ;(* *) diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el index d0a2c86e..06cabf30 100644 --- a/emacs/caml-emacs.el +++ b/emacs/caml-emacs.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Didier Remy, projet Cristal, INRIA Rocquencourt *) ;(* *) diff --git a/emacs/caml-font-old.el b/emacs/caml-font-old.el index 8faa542f..12c318c9 100644 --- a/emacs/caml-font-old.el +++ b/emacs/caml-font-old.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Jacques Garrigue and Ian T Zimmerman *) ;(* *) @@ -55,7 +55,7 @@ ; The same definition is in caml.el: ; we don't know in which order they will be loaded. (defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + "*Quote for character constants. \"'\" for OCaml, \"`\" for Caml-Light.") (defconst caml-font-lock-keywords (list diff --git a/emacs/caml-font.el b/emacs/caml-font.el index 95622546..d0eeb5c8 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -1,18 +1,5 @@ ;; caml-font: font-lock support for OCaml files -;; -;; rewrite and clean-up. -;; Changes: -;; - fontify strings and comments using syntactic font lock -;; - define a `font-lock-syntactic-face-function' to fontify ocamldoc comments -;; - fontify infix operators like mod, land, lsl, etc. -;; - fontify line number directives -;; - fontify "failwith" and "invalid_arg" like "raise" -;; - fontify '\x..' character constants -;; - use the regexp-opt function to build regexps (more readable) -;; - use backquote and comma in sexp (more readable) -;; - drop the `caml-quote-char' variable (I don't use caml-light :)) -;; - stop doing weird things with faces - +;; now with perfect parsing of comments and strings (require 'font-lock) @@ -36,9 +23,6 @@ (defconst caml-font-lock-keywords `( -;character literals - ("'\\(.\\|\\\\\\([ntbr\"'\\\\]\\|[0-9]\\{3\\}\\|x[0-9A-Fa-f]\\{2\\}\\)\\)'" - . font-lock-string-face) ;modules and constructors ("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) ;definition @@ -87,14 +71,299 @@ ((looking-at "(\\*\\*[^*]") 'caml-font-doccomment-face) (t 'font-lock-comment-face))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; In order to correctly fontify an OCaml buffer, it is necessary to +; lex the buffer to tell what is a comment and what is a string. +; We do this incrementally in a hook +; (font-lock-extend-after-change-region-function), which is called +; whenever the buffer changes. It sets the syntax-table property +; on each beginning and end of chars, strings, and comments. + +; This mode handles correctly all the strange cases in the following +; OCaml code. +; +; let l' _ = ();; +; let _' _ = ();; +; let l' = ();; +; let b2_' = ();; +; let a'a' = ();; +; let f2 _ _ = ();; +; let f3 _ _ _ = ();; +; let f' _ _ _ _ _ = ();; +; let hello = ();; +; +; (* ==== easy stuff ==== *) +; +; (* a comment *) +; (* "a string" in a comment *) +; (* "another string *)" in a comment *) +; (* not a string '"' in a comment *) +; "a string";; +; '"';; (* not a string *) +; +; (* ==== hard stuff ==== *) +; +; l'"' not not a string ";; +; _'"' also not not a string";; +; f2 0l'"';; (* not not not a string *) +; f2 0_'"';; (* also not not not a string *) +; f3 0.0l'"' not not not not a string ";; +; f3 0.0_'"';; (* not not not not not a string *) +; f2 0b01_'"';; (* not not not a string *) +; f3 0b2_'"' not not not not a string ";; +; f3 0b02_'"';; (* not not not not not a string *) +; '\'';; (* a char *) +; ' +; ';; (* a char *) +; '^M +; ';; (* also a char [replace ^M with one CR character] *) +; a'a';; (* not a char *) +; type ' +; a' t = X;; (* also not a char *) +; +; (* ==== far-out stuff ==== *) +; +; f'"'" "*) print_endline "hello";;(* \"" ;; +; (* f'"'" "*) print_endline "hello";;(* \"" ;; *) + + +(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]*" +) + +(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]?" +) + +; decimal integers are folded into the RE for floats to get longest-match +; without using posix-looking-at +(defconst caml-font-decimal-re + "[0-9][0-9_]*\\([lLn]\\|\\.[0-9_]*\\)?\\([eE][+-]?[0-9][0-9_]*\\)?" +) + +; match any ident or numeral token +(defconst caml-font-ident-or-num-re + (concat caml-font-ident-re "\\|" caml-font-int-re "\\|" caml-font-decimal-re) +) + +; 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]\\)\\)\\)'" +) + +; match a quote followed by a newline +(defconst caml-font-quote-newline-re + "'\\(\015\012\\|[\012\015]\\)" +) + +; match any token or sequence of tokens that cannot contain a +; quote, double quote, a start of comment, or a newline +; note: this is only to go faster than one character at a time +(defconst caml-font-other-re + "[^A-Za-z_0-9\012\015\300-\326\330-\366\370-\377'\"(]+" +) + +; match any sequence of non-special characters in a comment +; note: this is only to go faster than one character at a time +(defconst caml-font-other-comment-re + "[^(*\"'\012\015]+" +) + +; match any sequence of non-special characters in a string +; note: this is only to go faster than one character at a time +(defconst caml-font-other-string-re + "[^\\\"\012\015]" +) + +; match a newline +(defconst caml-font-newline-re + "\\(\015\012\\|[\012\015]\\)" +) + +; Put the 'caml-font-state property with the given state on the +; character before pos. Return nil if it was already there, t if not. +(defun caml-font-put-state (pos state) + (if (equal state (get-text-property (1- pos) 'caml-font-state)) + nil + (put-text-property (1- pos) pos 'caml-font-state state) + t) +) + +; Same as looking-at, but erase properties 'caml-font-state and +; 'syntax-table from the matched range +(defun caml-font-looking-at (re) + (let ((result (looking-at re))) + (when result + (remove-text-properties (match-beginning 0) (match-end 0) + '(syntax-table nil caml-font-state nil))) + result) +) + +; Annotate the buffer starting at point in state (st . depth) +; Set the 'syntax-table property on beginnings and ends of: +; - strings +; - chars +; - comments +; Also set the 'caml-font-state property on each LF character that is +; not preceded by a single quote. The property gives the state of the +; lexer (nil or t) after reading that character. + +; Leave the point at a point where the pre-existing 'caml-font-state +; property is consistent with the new parse, or at the end of the buffer. + +; depth is the depth of nested comments at this point +; it must be a non-negative integer +; st can be: +; nil -- we are in the base state +; t -- we are within a string + +(defun caml-font-annotate (st depth) + (let ((continue t)) + (while (and continue (not (eobp))) + (cond + ((and (equal st nil) (= depth 0)) ; base state, outside comment + (cond + ((caml-font-looking-at caml-font-ident-or-num-re) + (goto-char (match-end 0))) + ((caml-font-looking-at caml-font-char-re) + (put-text-property (point) (1+ (point)) + 'syntax-table (string-to-syntax "|")) + (put-text-property (1- (match-end 0)) (match-end 0) + 'syntax-table (string-to-syntax "|")) + (goto-char (match-end 0))) + ((caml-font-looking-at caml-font-quote-newline-re) + (goto-char (match-end 0))) + ((caml-font-looking-at "\"") + (put-text-property (point) (1+ (point)) + 'syntax-table (string-to-syntax "|")) + (goto-char (match-end 0)) + (setq st t)) + ((caml-font-looking-at "(\\*") + (put-text-property (point) (1+ (point)) + 'syntax-table (string-to-syntax "!")) + (goto-char (match-end 0)) + (setq depth 1)) + ((looking-at caml-font-newline-re) + (goto-char (match-end 0)) + (setq continue (caml-font-put-state (match-end 0) '(nil . 0)))) + ((caml-font-looking-at caml-font-other-re) + (goto-char (match-end 0))) + (t + (remove-text-properties (point) (1+ (point)) + '(syntax-table nil caml-font-state nil)) + (goto-char (1+ (point)))))) + ((equal st nil) ; base state inside comment + (cond + ((caml-font-looking-at "(\\*") + (goto-char (match-end 0)) + (setq depth (1+ depth))) + ((caml-font-looking-at "\\*)") + (goto-char (match-end 0)) + (setq depth (1- depth)) + (when (= depth 0) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "!")))) + ((caml-font-looking-at "\"") + (goto-char (match-end 0)) + (setq st t)) + ((caml-font-looking-at caml-font-char-re) + (goto-char (match-end 0))) + ((caml-font-looking-at caml-font-quote-newline-re) + (goto-char (match-end 0))) + ((caml-font-looking-at "''") + (goto-char (match-end 0))) + ((looking-at caml-font-newline-re) + (goto-char (match-end 0)) + (setq continue (caml-font-put-state (match-end 0) (cons nil depth)))) + ((caml-font-looking-at caml-font-other-comment-re) + (goto-char (match-end 0))) + (t + (remove-text-properties (point) (1+ (point)) + '(syntax-table nil caml-font-state nil)) + (goto-char (1+ (point)))))) + (t ; string state inside or outside a comment + (cond + ((caml-font-looking-at "\"") + (when (= depth 0) + (put-text-property (point) (1+ (point)) + 'syntax-table (string-to-syntax "|"))) + (goto-char (1+ (point))) + (setq st nil)) + ((caml-font-looking-at "\\\\[\"\\]") + (goto-char (match-end 0))) + ((looking-at caml-font-newline-re) + (goto-char (match-end 0)) + (setq continue (caml-font-put-state (match-end 0) (cons t depth)))) + ((caml-font-looking-at caml-font-other-string-re) + (goto-char (match-end 0))) + (t + (remove-text-properties (point) (1+ (point)) + '(syntax-table nil caml-font-state nil)) + (goto-char (1+ (point))))))))) +) + +; This is the hook function for font-lock-extend-after-change-function +; It finds the nearest saved state at the left of the changed text, +; calls caml-font-annotate to set the 'caml-font-state and 'syntax-table +; properties, then returns the range that was parsed by caml-font-annotate. +(defun caml-font-extend-after-change (beg end &optional old-len) + (save-excursion + (save-match-data + (let ((caml-font-modified (buffer-modified-p)) + start-at + end-at + state) + (remove-text-properties beg end '(syntax-table nil caml-font-state nil)) + (setq start-at + (or (and (> beg (point-min)) + (get-text-property (1- beg) 'caml-font-state) + beg) + (previous-single-property-change beg 'caml-font-state) + (point-min))) + (setq state (or (and (> start-at (point-min)) + (get-text-property (1- start-at) 'caml-font-state)) + (cons nil 0))) + (goto-char start-at) + (caml-font-annotate (car state) (cdr state)) + (setq end-at (point)) + (restore-buffer-modified-p caml-font-modified) + (cons start-at end-at)))) +) + +; We don't use the normal caml-mode syntax table because it contains an +; approximation of strings and comments that interferes with our +; annotations. +(defconst caml-font-syntax-table + (let ((tbl (make-syntax-table))) + (modify-syntax-entry ?' "w" tbl) + (modify-syntax-entry ?_ "w" tbl) + (modify-syntax-entry ?\" "." tbl) + (let ((i 192)) + (while (< i 256) + (or (= i 215) (= i 247) (modify-syntax-entry i "w" tbl)) + (setq i (1+ i)))) + tbl)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; font-lock commands are similar for caml-mode and inferior-caml-mode (defun caml-font-set-font-lock () + (setq parse-sexp-lookup-properties t) (setq font-lock-defaults - '(caml-font-lock-keywords - nil nil nil nil - (font-lock-syntactic-face-function . caml-font-syntactic-face))) - (font-lock-mode 1)) + (list + 'caml-font-lock-keywords ; keywords + nil ; keywords-only + nil ; case-fold + nil ; syntax-alist + nil ; syntax-begin + (cons 'font-lock-syntax-table caml-font-syntax-table) + '(font-lock-extend-after-change-region-function + . caml-font-extend-after-change) + '(font-lock-syntactic-face-function . caml-font-syntactic-face) + )) + (caml-font-extend-after-change (point-min) (point-max) 0) + (font-lock-mode 1) +) (add-hook 'caml-mode-hook 'caml-font-set-font-lock) @@ -104,11 +373,22 @@ ,@caml-font-lock-keywords)) (defun inferior-caml-set-font-lock () + (setq parse-sexp-lookup-properties t) (setq font-lock-defaults - '(inferior-caml-font-lock-keywords - nil nil nil nil - (font-lock-syntactic-face-function . caml-font-syntactic-face))) - (font-lock-mode 1)) + (list + 'inferior-caml-font-lock-keywords ; keywords + nil ; keywords-only + nil ; case-fold + nil ; syntax-alist + nil ; syntax-begin + (cons 'font-lock-syntax-table caml-font-syntax-table) + '(font-lock-extend-after-change-region-function + . caml-font-extend-after-change) + '(font-lock-syntactic-face-function . caml-font-syntactic-face) + )) + (caml-font-extend-after-change (point-min) (point-max) 0) + (font-lock-mode 1) +) (add-hook 'inferior-caml-mode-hooks 'inferior-caml-set-font-lock) (provide 'caml-font) diff --git a/emacs/caml-help.el b/emacs/caml-help.el index 2adba675..10196329 100644 --- a/emacs/caml-help.el +++ b/emacs/caml-help.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Didier Remy, projet Cristal, INRIA Rocquencourt *) ;(* *) @@ -199,7 +199,7 @@ (insert-file-contents file)) (message "Module %s not found" module)) (while (re-search-forward - "\\([ \t]*val\\|let\\|external\\| [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^ *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;" + "\\([ \t]*val\\|let\\|exception\\|external\\| [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^ *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;" (point-max) 'move) (pop-to-buffer (current-buffer)) (setq alist (cons (or (match-string 2) (match-string 3)) alist))) @@ -606,14 +606,18 @@ current buffer using \\[ocaml-qualified-identifier]." ) (if (stringp entry) (let ((here (point)) + (regex (regexp-quote entry)) (case-fold-search nil)) (goto-char (point-min)) (if (or (re-search-forward (concat "\\(val\\|exception\\|type\\|external\\|[|{;]\\) +" - (regexp-quote entry)) + regex) + ;; (concat "\\(val\\|exception\\|external\\) +\\(" + ;; regex "\\|( *" regex " *)\\)") (point-max) t) (re-search-forward - (concat "type [^{]*{[^}]*" (regexp-quote entry) " :") + (concat "type [^{]*{[^}]*" regex " :") + ;; (concat "\\(type\\|[|{;]\\) +" regex) (point-max) t) (progn (if (window-live-p window) (select-window window)) @@ -621,7 +625,7 @@ current buffer using \\[ocaml-qualified-identifier]." entry module)) ;; (search-forward entry (point-max) t) ) - (recenter 1) + (ocaml-help-show -1) (progn (message "Help for entry %s not found in module %s" entry module) @@ -656,6 +660,7 @@ Prefix arg 4 prompts for Module and identifier instead of guessing values from the possition of point in the current buffer. " (interactive "p") + (delete-overlay ocaml-help-ovl) (let ((module) (entry) (module-entry)) (cond ((= arg 4) @@ -669,7 +674,8 @@ from the possition of point in the current buffer. (mapcar 'list (ocaml-module-symbols (assoc module (ocaml-module-alist)))))) - (setq entry (completing-read "Value: " symbols nil t))) + (setq entry + (completing-read (format "Value: %s." module) symbols nil t))) (if (string-equal entry "") (setq entry nil)) ) (t @@ -740,6 +746,22 @@ buffer positions." (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) + +(defun ocaml-help-show (arg) + (let ((right (point)) + (left (progn (forward-word arg) (point)))) + (goto-char right) + (move-overlay ocaml-help-ovl left right (current-buffer)) + (recenter 1) + )) + (defun ocaml-link-goto (click) (interactive "e") (let* ((pos (caml-event-point-start click)) @@ -761,7 +783,7 @@ buffer positions." (if (setq link (assoc link (cdr ocaml-links))) (progn (goto-char (cadr link)) - (recenter 1))) + (ocaml-help-show 1))) (if (window-live-p window) (select-window window)) ))) diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el index 697e5817..25376eb2 100644 --- a/emacs/caml-hilit.el +++ b/emacs/caml-hilit.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Jacques Garrigue and Ian T Zimmerman *) ;(* *) @@ -16,7 +16,7 @@ ; defined also in caml.el (defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + "*Quote for character constants. \"'\" for OCaml, \"`\" for Caml-Light.") (defconst caml-mode-patterns (list @@ -53,7 +53,7 @@ "\\|\|\\|->\\|&\\|#") nil 'keyword) '(";" nil struct)) - "Hilit19 patterns used for Caml mode") + "Hilit19 patterns used for OCaml mode") (hilit-set-mode-patterns 'caml-mode caml-mode-patterns) (hilit-set-mode-patterns diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 3c7433a8..e42a0fc4 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) ;(* *) @@ -38,7 +38,7 @@ Their format is: is a space character (ASCII 0x20) is a line-feed character (ASCII 0x0A) num is a sequence of decimal digits - filename is a string with the lexical conventions of O'Caml + filename is a string with the lexical conventions of OCaml open-paren is an open parenthesis (ASCII 0x28) close-paren is a closed parenthesis (ASCII 0x29) data is any sequence of characters where is always followed by @@ -411,8 +411,7 @@ See `caml-types-location-re' for annotation file format. (unless (caml-types-not-in-file l-file r-file target-file) (setq annotation ()) (while (next-annotation) - (cond ((looking-at - "^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (cond ((looking-at "^\\([a-z]+\\)(\n \\(\\(.*\n \\)*.*\\)\n)") (let ((kind (caml-types-hcons (match-string 1) table)) (info (caml-types-hcons (match-string 2) table))) (setq annotation (cons (cons kind info) annotation)))))) diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el index 45d670c7..79321e00 100644 --- a/emacs/caml-xemacs.el +++ b/emacs/caml-xemacs.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Didier Remy, projet Cristal, INRIA Rocquencourt *) ;(* *) diff --git a/emacs/caml.el b/emacs/caml.el index 2e37bff5..d1127f78 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Jacques Garrigue and Ian T Zimmerman *) ;(* *) @@ -12,19 +12,19 @@ ;(* $Id$ *) -;;; caml.el --- O'Caml code editing commands for Emacs +;;; caml.el --- OCaml code editing commands for Emacs ;; Xavier Leroy, july 1993. ;;indentation code is Copyright (C) 1996 by Ian T Zimmerman ;;copying: covered by the current FSF General Public License. -;; indentation code adapted for Objective Caml by Jacques Garrigue, +;; indentation code adapted for OCaml by Jacques Garrigue, ;; july 1997. ;;user customizable variables (defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + "*Quote for character constants. \"'\" for OCaml, \"`\" for Caml-Light.") (defvar caml-imenu-enable nil "*Enable Imenu support.") @@ -484,7 +484,7 @@ have caml-electric-indent on, which see.") "Hook for caml-mode") (defun caml-mode () - "Major mode for editing Caml code. + "Major mode for editing OCaml code. \\{caml-mode-map}" @@ -588,7 +588,7 @@ have caml-electric-indent on, which see.") ;;; subshell support (defun caml-eval-region (start end) - "Send the current region to the inferior Caml process." + "Send the current region to the inferior OCaml process." (interactive"r") (require 'inf-caml) (inferior-caml-eval-region start end)) @@ -596,7 +596,7 @@ have caml-electric-indent on, which see.") ;; old version ---to be deleted later ; ; (defun caml-eval-phrase () -; "Send the current Caml phrase to the inferior Caml process." +; "Send the current OCaml phrase to the inferior Caml process." ; (interactive) ; (save-excursion ; (let ((bounds (caml-mark-phrase))) @@ -825,7 +825,7 @@ from an error message produced by camlc.") ;that way we get our effect even when we do \C-x` in compilation buffer (defadvice next-error (after caml-next-error activate) - "Reads the extra positional information provided by the Caml compiler. + "Reads the extra positional information provided by the OCaml compiler. Puts the point and the mark exactly around the erroneous program fragment. The erroneous fragment is also temporarily highlighted if @@ -903,7 +903,7 @@ whole string." ;; itz Thu Sep 24 19:02:42 PDT 1998 this is to have some level of ;; comfort when sending phrases to the toplevel and getting errors. (defun caml-goto-phrase-error () - "Find the error location in current Caml phrase." + "Find the error location in current OCaml phrase." (interactive) (require 'inf-caml) (let ((bounds (save-excursion (caml-mark-phrase)))) @@ -984,7 +984,7 @@ to the end. beg)) (defun caml-mark-phrase (&optional min-pos max-pos) - "Put mark at end of this Caml phrase, point at beginning. + "Put mark at end of this OCaml phrase, point at beginning. " (interactive) (let* ((beg (caml-find-phrase min-pos max-pos)) (end (point))) @@ -1756,7 +1756,7 @@ by |, insert one." (goto-char (match-end 0)))) ;; to mark phrases, so that repeated calls will take several of them -;; knows little about Ocaml appart literals and comments, so it should work +;; knows little about OCaml except literals and comments, so it should work ;; with other dialects as long as ;; marks the end of phrase. (defun caml-indent-phrase (arg) @@ -1912,7 +1912,7 @@ with prefix arg, indent that many phrases starting with the current phrase." (beginning-of-line 1) (backward-char 4))) -(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) +(autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t) (autoload 'caml-types-show-type "caml-types" "Show the type of expression or pattern at point." t) diff --git a/emacs/camldebug.el b/emacs/camldebug.el index 57a98701..0fd353ae 100644 --- a/emacs/camldebug.el +++ b/emacs/camldebug.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Jacques Garrigue and Ian T Zimmerman *) ;(* *) @@ -89,7 +89,7 @@ (define-derived-mode camldebug-mode comint-mode "Inferior CDB" - "Major mode for interacting with an inferior Camldebug process. + "Major mode for interacting with an inferior ocamldebug process. The following commands are available: diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el index f3e4c48d..5b864efc 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -1,6 +1,6 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Xavier Leroy and Jacques Garrigue *) ;(* *) @@ -12,7 +12,7 @@ ;(* $Id$ *) -;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer +;;; inf-caml.el --- run the OCaml toplevel in an Emacs buffer ;; Xavier Leroy, july 1993. @@ -37,14 +37,14 @@ (setq inferior-caml-mode-map (copy-keymap comint-mode-map))) -;; Augment Caml mode, so you can process Caml code in the source files. +;; Augment Caml mode, so you can process OCaml code in the source files. (defvar inferior-caml-program "ocaml" - "*Program name for invoking an inferior Caml from Emacs.") + "*Program name for invoking an inferior OCaml from Emacs.") (defun inferior-caml-mode () - "Major mode for interacting with an inferior Caml process. -Runs a Caml toplevel as a subprocess of Emacs, with I/O through an + "Major mode for interacting with an inferior OCaml process. +Runs an OCaml toplevel as a subprocess of Emacs, with I/O through an Emacs buffer. A history of input phrases is maintained. Phrases can be sent from another buffer in Caml mode. @@ -95,7 +95,7 @@ be sent from another buffer in Caml mode. (defun inferior-caml-mode-output-hook () (set-variable 'comint-output-filter-functions - (list (function inferior-caml-signal-output)) + (list (function inferior-caml-signal-output)) t)) (add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook) @@ -106,7 +106,7 @@ be sent from another buffer in Caml mode. (if (not cmd) (if (comint-check-proc inferior-caml-buffer-name) (setq cmd inferior-caml-program) - (setq cmd (read-from-minibuffer "Caml toplevel to run: " + (setq cmd (read-from-minibuffer "OCaml toplevel to run: " inferior-caml-program)))) (setq inferior-caml-program cmd) (let ((cmdlist (inferior-caml-args-to-list cmd)) @@ -124,11 +124,11 @@ be sent from another buffer in Caml mode. ;; caml-run-process-when-needed (defun run-caml (&optional cmd) - "Run an inferior Caml process. + "Run an inferior OCaml process. Input and output via buffer `*inferior-caml*'." (interactive (list (if (not (comint-check-proc inferior-caml-buffer-name)) - (read-from-minibuffer "Caml toplevel to run: " + (read-from-minibuffer "OCaml toplevel to run: " inferior-caml-program)))) (caml-run-process-if-needed cmd) (switch-to-buffer-other-window inferior-caml-buffer-name)) @@ -174,7 +174,7 @@ Input and output via buffer `*inferior-caml*'." ;; patched by Didier to move cursor after evaluation (defun inferior-caml-eval-region (start end) - "Send the current region to the inferior Caml process." + "Send the current region to the inferior OCaml process." (interactive "r") (save-excursion (caml-run-process-if-needed)) (save-excursion diff --git a/emacs/ocamltags.in b/emacs/ocamltags.in index aa3f8df1..2a6aadbf 100644 --- a/emacs/ocamltags.in +++ b/emacs/ocamltags.in @@ -2,7 +2,7 @@ ;(***********************************************************************) ;(* *) -;(* Objective Caml *) +;(* OCaml *) ;(* *) ;(* Jacques Garrigue and Ian T Zimmerman *) ;(* *) diff --git a/experimental/doligez/checkheaders b/experimental/doligez/checkheaders new file mode 100755 index 00000000..044080f2 --- /dev/null +++ b/experimental/doligez/checkheaders @@ -0,0 +1,159 @@ +#!/bin/sh + +####################################################################### +# # +# 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. # +# # +####################################################################### + +( +case $# in + 0) find . -type f -print;; + *) echo $1;; +esac +) | \ +while read f; do +awk -f - "$f" <<\EOF + +function checkline (x) { + return ( $0 ~ ("^.{0,4}" x) ); +} + +function hrule () { + return (checkline("[*#]{69}")); +} + +function blank () { + return (checkline(" {69}")); +} + +function ocaml () { + return (checkline(" {32}OCaml {32}") \ + || checkline(" {35}OCaml {32}") \ + || checkline(" MLTk, Tcl/Tk interface of OCaml ") \ + || checkline(" OCaml LablTk library ") \ + || checkline(" ocamlbuild ") \ + || checkline(" OCamldoc ") \ + ); +} + +function any () { + return (checkline(".{69}")); +} + +function copy1 () { + return (checkline(" Copyright +[-0-9]+ +Institut +National +de +Recherche +en +Informatique +et ")); +} + +function copy2 () { + return (checkline(" en Automatique")); +} + +function err () { + printf ("File \"%s\", line %d:\n", FILENAME, FNR); + printf (" Error: line %d of header is wrong.\n", FNR + offset); + print $0; +} + +function add_ignore_re (x) { + ignore_re[++ignore_re_index] = x; +} + +function add_exception (x) { + exception[++exception_index] = x; +} + +FNR == 1 { + offset = 0; + add_ignore_re("/\\.svn/"); + add_ignore_re("/\\.depend(\\.nt)?$"); + add_ignore_re("/\\.ignore$"); + add_ignore_re("\\.gif$"); + add_ignore_re("/[A-Z]*$"); + add_ignore_re("/README\\.[^/]*$"); + add_ignore_re("/Changes$"); + add_ignore_re("\\.mlpack$"); + add_ignore_re("\\.mllib$"); + add_ignore_re("\\.mltop$"); + add_ignore_re("\\.clib$"); + add_ignore_re("\\.odocl$"); + add_ignore_re("\\.itarget$"); + add_ignore_re("^\\./boot/"); + add_ignore_re("^\\./camlp4/test/"); + add_ignore_re("^\\./camlp4/unmaintained/"); + add_ignore_re("^\\./config/gnu/"); + add_ignore_re("^\\./experimental/"); + add_ignore_re("^\\./ocamlbuild/examples/"); + add_ignore_re("^\\./ocamlbuild/test/"); + add_ignore_re("^\\./otherlibs/labltk/builtin/"); + add_ignore_re("^\\./otherlibs/labltk/examples_"); + add_ignore_re("^\\./testsuite/"); + for (i in ignore_re){ + if (FILENAME ~ ignore_re[i]) { nextfile; } + } + add_exception("./asmrun/m68k.S"); # obsolete + add_exception("./build/camlp4-bootstrap-recipe.txt"); + add_exception("./build/new-build-system"); + add_exception("./ocamlbuild/ChangeLog"); + add_exception("./ocamlbuild/manual/myocamlbuild.ml"); # TeX input file ? + add_exception("./ocamlbuild/manual/trace.out"); # TeX input file + add_exception("./ocamldoc/Changes.txt"); + add_exception("./ocamldoc/ocamldoc.sty"); # public domain + add_exception("./otherlibs/labltk/browser/help.txt"); + add_exception("./otherlibs/labltk/camltk/modules"); # generated + add_exception("./otherlibs/labltk/labltk/modules"); # generated + add_exception("./tools/objinfo_helper.c"); # non-INRIA + add_exception("./tools/magic"); # public domain ? + add_exception("./Upgrading"); + add_exception("./win32caml/inriares.h"); # generated + add_exception("./win32caml/ocaml.rc"); # generated + add_exception("./win32caml/resource.h"); # generated + for (i in exception){ + if (FILENAME == exception[i]) { nextfile; } + } +} + +# 1 [!hrule] #! +# 2 [!hrule] empty +# 3 hrule +# 4 [blank] +# 5 ocaml title +# 6 blank +# 7 any author +# 8 [!blank] author +# 9 [!blank] author +#10 blank +#11 copy1 copyright +#12 copy2 copyright +#13 any copyright +#14 [!blank] copyright +#15 [!blank] copyright +#16 blank +#17 hrule + +FNR + offset == 1 && hrule() { ++offset; } +FNR + offset == 2 && hrule() { ++offset; } +FNR + offset == 3 && ! hrule() { err(); nextfile; } +FNR + offset == 4 && ! blank() { ++offset; } +FNR + offset == 5 && ! ocaml() { err(); nextfile; } +FNR + offset == 6 && ! blank() { err(); nextfile; } +FNR + offset == 7 && ! any() { err(); nextfile; } +FNR + offset == 8 && blank() { ++offset; } +FNR + offset == 9 && blank() { ++offset; } +FNR + offset ==10 && ! blank() { err(); nextfile; } +FNR + offset ==11 && ! copy1() { err(); nextfile; } +FNR + offset ==12 && ! copy2() { err(); nextfile; } +FNR + offset ==13 && ! any() { err(); nextfile; } +FNR + offset ==14 && blank() { ++offset; } +FNR + offset ==15 && blank() { ++offset; } +FNR + offset ==16 && ! blank() { err(); nextfile; } +FNR + offset ==17 && ! hrule() { err(); nextfile; } + +EOF +done diff --git a/experimental/garrigue/.cvsignore b/experimental/garrigue/.cvsignore new file mode 100644 index 00000000..4c57147b --- /dev/null +++ b/experimental/garrigue/.cvsignore @@ -0,0 +1 @@ +*.out *.out2 \ No newline at end of file diff --git a/experimental/garrigue/caml_set_oid.diffs b/experimental/garrigue/caml_set_oid.diffs new file mode 100644 index 00000000..aaaa160e --- /dev/null +++ b/experimental/garrigue/caml_set_oid.diffs @@ -0,0 +1,141 @@ +Index: byterun/intern.c +=================================================================== +--- byterun/intern.c (revision 11929) ++++ byterun/intern.c (working copy) +@@ -27,6 +27,7 @@ + #include "memory.h" + #include "mlvalues.h" + #include "misc.h" ++#include "obj.h" + #include "reverse.h" + + static unsigned char * intern_src; +@@ -139,6 +140,14 @@ + dest = (value *) (intern_dest + 1); + *intern_dest = Make_header(size, tag, intern_color); + intern_dest += 1 + size; ++ /* For objects, we need to freshen the oid */ ++ if (tag == Object_tag) { ++ intern_rec(dest++); ++ intern_rec(dest++); ++ caml_set_oid((value)(dest-2)); ++ size -= 2; ++ if (size == 0) return; ++ } + for(/*nothing*/; size > 1; size--, dest++) + intern_rec(dest); + goto tailcall; +Index: byterun/obj.c +=================================================================== +--- byterun/obj.c (revision 11929) ++++ byterun/obj.c (working copy) +@@ -25,6 +25,7 @@ + #include "minor_gc.h" + #include "misc.h" + #include "mlvalues.h" ++#include "obj.h" + #include "prims.h" + + CAMLprim value caml_static_alloc(value size) +@@ -212,6 +213,16 @@ + return (tag == Field(meths,li) ? Field (meths, li-1) : 0); + } + ++/* Generate ids on the C side, to avoid races */ ++ ++CAMLprim value caml_set_oid (value obj) ++{ ++ static value last_oid = 1; ++ Field(obj,1) = last_oid; ++ last_oid += 2; ++ return obj; ++} ++ + /* these two functions might be useful to an hypothetical JIT */ + + #ifdef CAML_JIT +Index: byterun/obj.h +=================================================================== +--- byterun/obj.h (revision 0) ++++ byterun/obj.h (revision 0) +@@ -0,0 +1,28 @@ ++/***********************************************************************/ ++/* */ ++/* OCaml */ ++/* */ ++/* Jacques Garrigue, 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. */ ++/* */ ++/***********************************************************************/ ++ ++/* $Id$ */ ++ ++/* Primitives for the Obj and CamlinternalOO modules */ ++ ++#ifndef CAML_OBJ_H ++#define CAML_OBJ_H ++ ++#include "misc.h" ++#include "mlvalues.h" ++ ++/* Set the OID of an object to a fresh value */ ++/* returns the same object as result */ ++value caml_set_oid (value obj); ++ ++#endif /* CAML_OBJ_H */ +Index: stdlib/camlinternalOO.ml +=================================================================== +--- stdlib/camlinternalOO.ml (revision 11929) ++++ stdlib/camlinternalOO.ml (working copy) +@@ -15,23 +15,15 @@ + + open Obj + +-(**** Object representation ****) ++(**** OID handling ****) + +-let last_id = ref 0 +-let new_id () = +- let id = !last_id in incr last_id; id ++external set_oid : t -> t = "caml_set_oid" "noalloc" + +-let set_id o id = +- let id0 = !id in +- Array.unsafe_set (Obj.magic o : int array) 1 id0; +- id := id0 + 1 +- + (**** Object copy ****) + + let copy o = +- let o = (Obj.obj (Obj.dup (Obj.repr o))) in +- set_id o last_id; +- o ++ let o = Obj.dup (Obj.repr o) in ++ Obj.obj (set_oid o) + + (**** Compression options ****) + (* Parameters *) +@@ -355,8 +347,7 @@ + let obj = Obj.new_block Obj.object_tag table.size in + (* XXX Appel de [caml_modify] *) + Obj.set_field obj 0 (Obj.repr table.methods); +- set_id obj last_id; +- (Obj.obj obj) ++ Obj.obj (set_oid obj) + + let create_object_opt obj_0 table = + if (Obj.magic obj_0 : bool) then obj_0 else begin +@@ -364,8 +355,7 @@ + let obj = Obj.new_block Obj.object_tag table.size in + (* XXX Appel de [caml_modify] *) + Obj.set_field obj 0 (Obj.repr table.methods); +- set_id obj last_id; +- (Obj.obj obj) ++ Obj.obj (set_oid obj) + end + + let rec iter_f obj = diff --git a/experimental/garrigue/coerce.diffs b/experimental/garrigue/coerce.diffs new file mode 100644 index 00000000..e90e1fc9 --- /dev/null +++ b/experimental/garrigue/coerce.diffs @@ -0,0 +1,93 @@ +Index: typing/ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.201 +diff -u -r1.201 ctype.ml +--- typing/ctype.ml 5 Apr 2006 02:28:13 -0000 1.201 ++++ typing/ctype.ml 17 May 2006 23:48:22 -0000 +@@ -490,6 +490,31 @@ + unmark_class_signature sign; + Some reason + ++(* Variant for checking principality *) ++ ++let rec free_nodes_rec ty = ++ let ty = repr ty in ++ if ty.level >= lowest_level then begin ++ if ty.level <= !current_level then raise Exit; ++ ty.level <- pivot_level - ty.level; ++ begin match ty.desc with ++ Tvar -> ++ raise Exit ++ | Tobject (ty, _) -> ++ free_nodes_rec ty ++ | Tfield (_, _, ty1, ty2) -> ++ free_nodes_rec ty1; free_nodes_rec ty2 ++ | Tvariant row -> ++ let row = row_repr row in ++ iter_row free_nodes_rec {row with row_bound = []}; ++ if not (static_row row) then free_nodes_rec row.row_more ++ | _ -> ++ iter_type_expr free_nodes_rec ty ++ end; ++ end ++ ++let has_free_nodes ty = ++ try free_nodes_rec ty; false with Exit -> true + + (**********************) + (* Type duplication *) +Index: typing/ctype.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v +retrieving revision 1.54 +diff -u -r1.54 ctype.mli +--- typing/ctype.mli 5 Apr 2006 02:28:13 -0000 1.54 ++++ typing/ctype.mli 17 May 2006 23:48:22 -0000 +@@ -228,6 +228,9 @@ + val closed_class: + type_expr list -> class_signature -> closed_class_failure option + (* Check whether all type variables are bound *) ++val has_free_nodes: type_expr -> bool ++ (* Check whether there are free type variables, or nodes with ++ level lower or equal to !current_level *) + + val unalias: type_expr -> type_expr + val signature_of_class_type: class_type -> class_signature +Index: typing/typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.181 +diff -u -r1.181 typecore.ml +--- typing/typecore.ml 16 Apr 2006 23:28:22 -0000 1.181 ++++ typing/typecore.ml 17 May 2006 23:48:22 -0000 +@@ -1183,12 +1183,29 @@ + let (ty', force) = + Typetexp.transl_simple_type_delayed env sty' + in ++ if !Clflags.principal then begin_def (); + let arg = type_exp env sarg in ++ let has_fv = ++ if !Clflags.principal then begin ++ end_def (); ++ let b = has_free_nodes arg.exp_type in ++ Ctype.unify env arg.exp_type (newvar ()); ++ b ++ end else ++ free_variables arg.exp_type <> [] ++ in + begin match arg.exp_desc, !self_coercion, (repr ty').desc with + Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, + Tconstr(path',_,_) when Path.same path path' -> + r := sexp.pexp_loc :: !r; + force () ++ | _ when not has_fv -> ++ begin try ++ let force' = subtype env arg.exp_type ty' in ++ force (); force' () ++ with Subtype (tr1, tr2) -> ++ raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2))) ++ end + | _ -> + let ty, b = enlarge_type env ty' in + force (); diff --git a/experimental/garrigue/dirs_multimatch b/experimental/garrigue/dirs_multimatch new file mode 100644 index 00000000..b4495146 --- /dev/null +++ b/experimental/garrigue/dirs_multimatch @@ -0,0 +1 @@ +parsing typing bytecomp driver toplevel \ No newline at end of file diff --git a/experimental/garrigue/dirs_poly b/experimental/garrigue/dirs_poly new file mode 100644 index 00000000..3aec606e --- /dev/null +++ b/experimental/garrigue/dirs_poly @@ -0,0 +1 @@ +bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml diff --git a/experimental/garrigue/fixedtypes.ml b/experimental/garrigue/fixedtypes.ml new file mode 100644 index 00000000..a7d7ca4a --- /dev/null +++ b/experimental/garrigue/fixedtypes.ml @@ -0,0 +1,77 @@ +(* cvs update -r fixedtypes parsing typing *) + +(* recursive types *) +class c = object (self) method m = 1 method s = self end +module type S = sig type t = private #c end;; + +module M : S = struct type t = c end +module type S' = S with type t = c;; + +class d = object inherit c method n = 2 end +module type S2 = S with type t = private #d;; +module M2 : S = struct type t = d end;; +module M3 : S = struct type t = private #d end;; + +module T1 = struct + type ('a,'b) a = [`A of 'a | `B of 'b] + type ('a,'b) b = [`Z | ('a,'b) a] +end +module type T2 = sig + type a and b + val evala : a -> int + val evalb : b -> int +end +module type T3 = sig + type a0 = private [> (a0,b0) T1.a] + and b0 = private [> (a0,b0) T1.b] +end +module type T4 = sig + include T3 + include T2 with type a = a0 and type b = b0 +end +module F(X:T4) = struct + type a = X.a and b = X.b + let a = X.evala (`B `Z) + let b = X.evalb (`A(`B `Z)) + let a2b (x : a) : b = `A x + let b2a (x : b) : a = `B x +end +module M4 = struct + type a = [`A of a | `B of b | `ZA] + and b = [`A of a | `B of b | `Z] + type a0 = a + type b0 = b + let rec eval0 = function + `A a -> evala a + | `B b -> evalb b + and evala : a -> int = function + #T1.a as x -> 1 + eval0 x + | `ZA -> 3 + and evalb : b -> int = function + #T1.a as x -> 1 + eval0 x + | `Z -> 7 +end +module M5 = F(M4) + +module M6 : sig + class ci : int -> + object + val x : int + method x : int + method move : int -> unit + end + type c = private #ci + val create : int -> c +end = struct + class ci x = object + val mutable x : int = x + method x = x + method move d = x <- x+d + end + type c = ci + let create = new ci +end +let f (x : M6.c) = x#move 3; x#x;; + +module M : sig type t = private [> `A of bool] end = + struct type t = [`A of int] end diff --git a/experimental/garrigue/gadt-escape-check.diffs b/experimental/garrigue/gadt-escape-check.diffs new file mode 100644 index 00000000..3e4a44e2 --- /dev/null +++ b/experimental/garrigue/gadt-escape-check.diffs @@ -0,0 +1,519 @@ +Index: typing/env.ml +=================================================================== +--- typing/env.ml (revision 11214) ++++ typing/env.ml (working copy) +@@ -20,6 +20,7 @@ + open Longident + open Path + open Types ++open Btype + + + type error = +@@ -56,7 +57,7 @@ + cltypes: (Path.t * cltype_declaration) Ident.tbl; + summary: summary; + local_constraints: bool; +- level_map: (int * int) list; ++ gadt_instances: (int * TypeSet.t ref) list; + } + + and module_components = module_components_repr Lazy.t +@@ -96,7 +97,7 @@ + modules = Ident.empty; modtypes = Ident.empty; + components = Ident.empty; classes = Ident.empty; + cltypes = Ident.empty; +- summary = Env_empty; local_constraints = false; level_map = [] } ++ summary = Env_empty; local_constraints = false; gadt_instances = [] } + + let diff_keys is_local tbl1 tbl2 = + let keys2 = Ident.keys tbl2 in +@@ -286,13 +287,14 @@ + (* the level is changed when updating newtype definitions *) + if !Clflags.principal then begin + match level, decl.type_newtype_level with +- Some level, Some def_level when level < def_level -> raise Not_found ++ Some level, Some (_, exp_level) when level < exp_level -> raise Not_found + | _ -> () + end; + match decl.type_manifest with + | Some body when decl.type_private = Public + || decl.type_kind <> Type_abstract +- || Btype.has_constr_row body -> (decl.type_params, body) ++ || Btype.has_constr_row body -> ++ (decl.type_params, body, may_map snd decl.type_newtype_level) + (* The manifest type of Private abstract data types without + private row are still considered unknown to the type system. + Hence, this case is caught by the following clause that also handles +@@ -308,7 +310,7 @@ + match decl.type_manifest with + (* The manifest type of Private abstract data types can still get + an approximation using their manifest type. *) +- | Some body -> (decl.type_params, body) ++ | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) + | _ -> raise Not_found + + let find_modtype_expansion path env = +@@ -453,32 +455,42 @@ + and lookup_cltype = + lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) + +-(* Level handling *) ++(* GADT instance tracking *) + +-(* The level map is a list of pairs describing separate segments (lv,lv'), +- lv < lv', organized in decreasing order. +- The definition level is obtained by mapping a level in a segment to the +- high limit of this segment. +- The definition level of a newtype should be greater or equal to +- the highest level of the newtypes in its manifest type. +- *) ++let add_gadt_instance_level lv env = ++ {env with ++ gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} + +-let rec map_level lv = function +- | [] -> lv +- | (lv1, lv2) :: rem -> +- if lv > lv2 then lv else +- if lv >= lv1 then lv2 else map_level lv rem ++let is_Tlink = function {desc = Tlink _} -> true | _ -> false + +-let map_newtype_level env lv = map_level lv env.level_map ++let gadt_instance_level env t = ++ let rec find_instance = function ++ [] -> None ++ | (lv, r) :: rem -> ++ if TypeSet.exists is_Tlink !r then ++ r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; ++ if TypeSet.mem t !r then Some lv else find_instance rem ++ in find_instance env.gadt_instances + +-(* precondition: lv < lv' *) +-let rec add_level lv lv' = function +- | [] -> [lv, lv'] +- | (lv1, lv2) :: rem as l -> +- if lv2 < lv then (lv, lv') :: l else +- if lv' < lv1 then (lv1, lv2) :: add_level lv lv' rem +- else add_level (max lv lv1) (min lv' lv2) rem ++let add_gadt_instances env lv tl = ++ let r = ++ try List.assoc lv env.gadt_instances with Not_found -> assert false in ++ r := List.fold_right TypeSet.add tl !r + ++(* Only use this after expand_head! *) ++let add_gadt_instance_chain env lv t = ++ let r = ++ try List.assoc lv env.gadt_instances with Not_found -> assert false in ++ let rec add_instance t = ++ let t = repr t in ++ if not (TypeSet.mem t !r) then begin ++ r := TypeSet.add t !r; ++ match t.desc with ++ Tconstr (p, _, memo) -> ++ may add_instance (find_expans Private p !memo) ++ | _ -> () ++ end ++ in add_instance t + + (* Expand manifest module type names at the top of the given module type *) + +@@ -497,7 +509,7 @@ + let constructors_of_type ty_path decl = + let handle_variants cstrs = + Datarepr.constructor_descrs +- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) ++ (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) + cstrs decl.type_private + in + match decl.type_kind with +@@ -510,7 +522,7 @@ + match decl.type_kind with + Type_record(labels, rep) -> + Datarepr.label_descrs +- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) ++ (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) + labels rep decl.type_private + | Type_variant _ | Type_abstract -> [] + +@@ -773,14 +785,13 @@ + and add_cltype id ty env = + store_cltype id (Pident id) ty env + +-let add_local_constraint id info mlv env = ++let add_local_constraint id info elv env = + match info with +- {type_manifest = Some ty; type_newtype_level = Some lv} -> +- (* use the newtype level for this definition, lv is the old one *) +- let env = add_type id {info with type_newtype_level = Some mlv} env in +- let level_map = +- if lv < mlv then add_level lv mlv env.level_map else env.level_map in +- { env with local_constraints = true; level_map = level_map } ++ {type_manifest = Some ty; type_newtype_level = Some (lv, _)} -> ++ (* elv is the expansion level, lv is the definition level *) ++ let env = ++ add_type id {info with type_newtype_level = Some (lv, elv)} env in ++ { env with local_constraints = true } + | _ -> assert false + + (* Insertion of bindings by name *) +Index: typing/typecore.ml +=================================================================== +--- typing/typecore.ml (revision 11214) ++++ typing/typecore.ml (working copy) +@@ -1989,6 +1989,7 @@ + end + | Pexp_newtype(name, sbody) -> + (* Create a fake abstract type declaration for name. *) ++ let level = get_current_level () in + let decl = { + type_params = []; + type_arity = 0; +@@ -1996,7 +1997,7 @@ + type_private = Public; + type_manifest = None; + type_variance = []; +- type_newtype_level = Some (get_current_level ()); ++ type_newtype_level = Some (level, level); + } + in + let ty = newvar () in +@@ -2421,6 +2422,7 @@ + begin_def (); + Ident.set_current_time (get_current_level ()); + let lev = Ident.current_time () in ++ let env = Env.add_gadt_instance_level lev env in + Ctype.init_def (lev+1000); + if !Clflags.principal then begin_def (); (* propagation of the argument *) + let ty_arg' = newvar () in +Index: typing/typedecl.ml +=================================================================== +--- typing/typedecl.ml (revision 11214) ++++ typing/typedecl.ml (working copy) +@@ -404,7 +404,7 @@ + else if to_check path' && not (List.mem path' prev_exp) then begin + try + (* Attempt expansion *) +- let (params0, body0) = Env.find_type_expansion path' env in ++ let (params0, body0, _) = Env.find_type_expansion path' env in + let (params, body) = + Ctype.instance_parameterized_type params0 body0 in + begin +Index: typing/types.mli +=================================================================== +--- typing/types.mli (revision 11214) ++++ typing/types.mli (working copy) +@@ -144,9 +144,9 @@ + type_manifest: type_expr option; + type_variance: (bool * bool * bool) list; + (* covariant, contravariant, weakly contravariant *) +- type_newtype_level: int option } ++ type_newtype_level: (int * int) option } ++ (* definition level * expansion level *) + +- + and type_kind = + Type_abstract + | Type_record of +Index: typing/ctype.ml +=================================================================== +--- typing/ctype.ml (revision 11214) ++++ typing/ctype.ml (working copy) +@@ -470,7 +470,7 @@ + free_variables := (ty, real) :: !free_variables + | Tconstr (path, tl, _), Some env -> + begin try +- let (_, body) = Env.find_type_expansion path env in ++ let (_, body, _) = Env.find_type_expansion path env in + if (repr body).level <> generic_level then + free_variables := (ty, real) :: !free_variables + with Not_found -> () +@@ -687,7 +687,7 @@ + try + match (Env.find_type p env).type_newtype_level with + | None -> Path.binding_time p +- | Some x -> x ++ | Some (x, _) -> x + with + | _ -> + (* no newtypes in predef *) +@@ -696,9 +696,13 @@ + let rec update_level env level ty = + let ty = repr ty in + if ty.level > level then begin ++ if !Clflags.principal && 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 -> () ++ end; + match ty.desc with +- Tconstr(p, tl, abbrev) +- when level < Env.map_newtype_level env (get_level env p) -> ++ Tconstr(p, tl, abbrev) when level < get_level env p -> + (* Try first to replace an abbreviation by its expansion. *) + begin try + (* if is_newtype env p then raise Cannot_expand; *) +@@ -1025,7 +1029,7 @@ + | Some (env, newtype_lev) -> + let existentials = List.map copy cstr.cstr_existentials in + let process existential = +- let decl = new_declaration (Some newtype_lev) None in ++ let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in + let (id, new_env) = + Env.enter_type (get_new_abstract_name ()) decl !env in + env := new_env; +@@ -1271,7 +1275,7 @@ + end; + ty + | None -> +- let (params, body) = ++ let (params, body, lv) = + try find_type_expansion level path env with Not_found -> + raise Cannot_expand + in +@@ -1284,6 +1288,15 @@ + ty.desc <- Tvariant { row with row_name = Some (path, args) } + | _ -> () + end; ++ (* For gadts, remember type as non exportable *) ++ if !Clflags.principal then begin ++ match lv with ++ Some lv -> 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 + | _ -> +@@ -1306,15 +1319,7 @@ + let try_expand_once env ty = + let ty = repr ty in + match ty.desc with +- Tconstr (p, _, _) -> +- let ty' = repr (expand_abbrev env ty) in +- if !Clflags.principal then begin +- match (Env.find_type p env).type_newtype_level with +- Some lv when ty.level < Env.map_newtype_level env lv -> +- link_type ty ty' +- | _ -> () +- end; +- ty' ++ Tconstr (p, _, _) -> repr (expand_abbrev env ty) + | _ -> raise Cannot_expand + + let _ = forward_try_expand_once := try_expand_once +@@ -1324,11 +1329,16 @@ + 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 +- begin try +- try_expand_head env ty' +- with Cannot_expand -> +- ty' +- end ++ let ty'' = ++ try try_expand_head env ty' ++ with Cannot_expand -> ty' ++ in ++ if !Clflags.principal then begin ++ match Env.gadt_instance_level env ty'' with ++ None -> () ++ | Some lv -> Env.add_gadt_instance_chain env lv ty ++ end; ++ ty'' + + (* Expand once the head of a type *) + let expand_head_once env ty = +@@ -1405,7 +1415,7 @@ + *) + let generic_abbrev env path = + try +- let (_, body) = Env.find_type_expansion path env in ++ let (_, body, _) = Env.find_type_expansion path env in + (repr body).level = generic_level + with + Not_found -> +@@ -1742,7 +1752,7 @@ + let reify env t = + let newtype_level = get_newtype_level () in + let create_fresh_constr lev row = +- let decl = new_declaration (Some (newtype_level)) None in ++ let decl = new_declaration (Some (newtype_level, newtype_level)) None in + let name = + let name = get_new_abstract_name () in + if row then name ^ "#row" else name +@@ -2065,7 +2075,7 @@ + update_level !env t1.level t2; + link_type t1 t2 + | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) +- when Path.same p1 p2 && actual_mode !env = Old ++ when Path.same p1 p2 (* && actual_mode !env = Old *) + (* This optimization assumes that t1 does not expand to t2 + (and conversely), so we fall back to the general case + when any of the types has a cached expansion. *) +@@ -2091,6 +2101,15 @@ + if unify_eq !env t1' t2' then () else + + let t1 = repr t1 and t2 = repr t2 in ++ if !Clflags.principal 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 -> () ++ end; + if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then + unify3 env t1 t1' t2 t2' + else +Index: typing/env.mli +=================================================================== +--- typing/env.mli (revision 11214) ++++ typing/env.mli (working copy) +@@ -33,14 +33,19 @@ + val find_cltype: Path.t -> t -> cltype_declaration + + val find_type_expansion: +- ?use_local:bool -> ?level:int -> Path.t -> t -> type_expr list * type_expr +-val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr ++ ?use_local:bool -> ?level:int -> Path.t -> t -> ++ type_expr list * type_expr * int option ++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 has_local_constraints: t -> bool +-val map_newtype_level: t -> int -> int ++val add_gadt_instance_level: int -> t -> t ++val gadt_instance_level: t -> type_expr -> int option ++val add_gadt_instances: t -> int -> type_expr list -> unit ++val add_gadt_instance_chain: t -> int -> type_expr -> unit + + (* Lookup by long identifiers *) + +Index: typing/types.ml +=================================================================== +--- typing/types.ml (revision 11214) ++++ typing/types.ml (working copy) +@@ -146,8 +146,8 @@ + type_private: private_flag; + type_manifest: type_expr option; + type_variance: (bool * bool * bool) list; +- type_newtype_level: int option } + (* covariant, contravariant, weakly contravariant *) ++ type_newtype_level: (int * int) option } + + and type_kind = + Type_abstract +Index: testsuite/tests/typing-gadts/test.ml +=================================================================== +--- testsuite/tests/typing-gadts/test.ml (revision 11214) ++++ testsuite/tests/typing-gadts/test.ml (working copy) +@@ -159,17 +159,21 @@ + + let ky x y = ignore (x = y); x ;; + ++let test : type a. a t -> a = ++ function Int -> ky (1 : a) 1 ++;; ++ + let test : type a. a t -> a = fun x -> +- let r = match x with Int -> ky (1 : a) 1 ++ let r = match x with Int -> ky (1 : a) 1 (* fails *) + in r + ;; + let test : type a. a t -> a = fun x -> +- let r = match x with Int -> ky 1 (1 : a) ++ let r = match x with Int -> ky 1 (1 : a) (* fails *) + in r + ;; + let test : type a. a t -> a = fun x -> +- let r = match x with Int -> (1 : a) +- in r (* fails too *) ++ let r = match x with Int -> (1 : a) (* ok! *) ++ in r + ;; + let test : type a. a t -> a = fun x -> + let r : a = match x with Int -> 1 +@@ -178,7 +182,7 @@ + let test2 : type a. a t -> a option = fun x -> + let r = ref None in + begin match x with Int -> r := Some (1 : a) end; +- !r (* normalized to int option *) ++ !r (* ok *) + ;; + let test2 : type a. a t -> a option = fun x -> + let r : a option ref = ref None in +@@ -190,19 +194,19 @@ + let u = ref None in + begin match x with Int -> r := Some 1; u := !r end; + !u +-;; (* fail *) ++;; (* ok (u non-ambiguous) *) + let test2 : type a. a t -> a option = fun x -> + let r : a option ref = ref None in + let u = ref None in + begin match x with Int -> u := Some 1; r := !u end; + !u +-;; (* fail *) ++;; (* fails because u : (int | a) option ref *) + let test2 : type a. a t -> a option = fun x -> + let u = ref None in + let r : a option ref = ref None in + begin match x with Int -> r := Some 1; u := !r end; + !u +-;; (* fail *) ++;; (* ok *) + let test2 : type a. a t -> a option = fun x -> + let u = ref None in + let a = +@@ -210,32 +214,32 @@ + begin match x with Int -> r := Some 1; u := !r end; + !u + in a +-;; (* fail *) ++;; (* ok *) + + (* Effect of external consraints *) + + let f (type a) (x : a t) y = + ignore (y : a); +- let r = match x with Int -> (y : a) in (* fails *) ++ let r = match x with Int -> (y : a) in (* ok *) + r + ;; + let f (type a) (x : a t) y = + let r = match x with Int -> (y : a) in +- ignore (y : a); (* fails *) ++ ignore (y : a); (* ok *) + r + ;; + let f (type a) (x : a t) y = + ignore (y : a); +- let r = match x with Int -> y in ++ let r = match x with Int -> y in (* ok *) + r + ;; + let f (type a) (x : a t) y = + let r = match x with Int -> y in +- ignore (y : a); ++ ignore (y : a); (* ok *) + r + ;; + let f (type a) (x : a t) (y : a) = +- match x with Int -> y (* should return an int! *) ++ match x with Int -> y (* returns 'a *) + ;; + + (* Pattern matching *) +@@ -307,4 +311,4 @@ + | {left=TE TC; right=D [|1.0|]} -> 14 + | {left=TA; right=D 0} -> -1 + | {left=TA; right=D z} -> z +-;; (* warn *) ++;; (* ok *) diff --git a/experimental/garrigue/marshal_objects.diffs b/experimental/garrigue/marshal_objects.diffs new file mode 100644 index 00000000..bb9b4dd7 --- /dev/null +++ b/experimental/garrigue/marshal_objects.diffs @@ -0,0 +1,800 @@ +? bytecomp/alpha_eq.ml +Index: bytecomp/lambda.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v +retrieving revision 1.44 +diff -u -r1.44 lambda.ml +--- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000 1.44 ++++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000 +@@ -287,9 +287,10 @@ + let compare = compare + end) + +-let free_ids get l = ++let free_ids get used l = + let fv = ref IdentSet.empty in + let rec free l = ++ let old = !fv in + iter free l; + fv := List.fold_right IdentSet.add (get l) !fv; + match l with +@@ -307,17 +308,20 @@ + fv := IdentSet.remove v !fv + | Lassign(id, e) -> + fv := IdentSet.add id !fv ++ | Lifused(id, e) -> ++ if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv + | Lvar _ | Lconst _ | Lapply _ + | Lprim _ | Lswitch _ | Lstaticraise _ + | Lifthenelse _ | Lsequence _ | Lwhile _ +- | Lsend _ | Levent _ | Lifused _ -> () ++ | Lsend _ | Levent _ -> () + in free l; !fv + +-let free_variables l = +- free_ids (function Lvar id -> [id] | _ -> []) l ++let free_variables ?(ifused=false) l = ++ free_ids (function Lvar id -> [id] | _ -> []) ifused l + + let free_methods l = +- free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l ++ free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) ++ false l + + (* Check if an action has a "when" guard *) + let raise_count = ref 0 +Index: bytecomp/lambda.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v +retrieving revision 1.42 +diff -u -r1.42 lambda.mli +--- bytecomp/lambda.mli 25 Aug 2005 15:35:16 -0000 1.42 ++++ bytecomp/lambda.mli 2 Feb 2006 05:08:56 -0000 +@@ -177,7 +177,7 @@ + + val iter: (lambda -> unit) -> lambda -> unit + module IdentSet: Set.S with type elt = Ident.t +-val free_variables: lambda -> IdentSet.t ++val free_variables: ?ifused:bool -> lambda -> IdentSet.t + val free_methods: lambda -> IdentSet.t + + val transl_path: Path.t -> lambda +Index: bytecomp/translclass.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v +retrieving revision 1.38 +diff -u -r1.38 translclass.ml +--- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38 ++++ bytecomp/translclass.ml 2 Feb 2006 05:08:56 -0000 +@@ -46,6 +46,10 @@ + + let lfield v i = Lprim(Pfield i, [Lvar v]) + ++let ltuple l = Lprim(Pmakeblock(0,Immutable), l) ++ ++let lprim name args = Lapply(oo_prim name, args) ++ + let transl_label l = share (Const_immstring l) + + let rec transl_meth_list lst = +@@ -68,8 +72,8 @@ + Lvar offset])])])) + + let transl_val tbl create name = +- Lapply (oo_prim (if create then "new_variable" else "get_variable"), +- [Lvar tbl; transl_label name]) ++ lprim (if create then "new_variable" else "get_variable") ++ [Lvar tbl; transl_label name] + + let transl_vals tbl create vals rem = + List.fold_right +@@ -82,7 +86,7 @@ + (fun (nm, id) rem -> + try + (nm, id, +- Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) ++ lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)]) + :: rem + with Not_found -> rem) + inh_meths [] +@@ -97,17 +101,15 @@ + let (inh_init, obj_init, has_init) = init obj' in + if obj_init = lambda_unit then + (inh_init, +- Lapply (oo_prim (if has_init then "create_object_and_run_initializers" +- else"create_object_opt"), +- [obj; Lvar cl])) ++ lprim (if has_init then "create_object_and_run_initializers" ++ else"create_object_opt") ++ [obj; Lvar cl]) + else begin + (inh_init, +- Llet(Strict, obj', +- Lapply (oo_prim "create_object_opt", [obj; Lvar cl]), ++ Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl], + Lsequence(obj_init, + if not has_init then Lvar obj' else +- Lapply (oo_prim "run_initializers_opt", +- [obj; Lvar obj'; Lvar cl])))) ++ lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl]))) + end + + let rec build_object_init cl_table obj params inh_init obj_init cl = +@@ -203,14 +205,13 @@ + + + let bind_method tbl lab id cl_init = +- Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", +- [Lvar tbl; transl_label lab]), ++ Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab], + cl_init) + +-let bind_methods tbl meths vals cl_init = +- let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in ++let bind_methods tbl methl vals cl_init = + let len = List.length methl and nvals = List.length vals in +- if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else ++ if len < 2 && nvals = 0 then ++ List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else + let ids = Ident.create "ids" in + let i = ref len in +@@ -229,21 +230,19 @@ + vals' cl_init) + in + Llet(StrictOpt, ids, +- Lapply (oo_prim getter, +- [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), ++ lprim getter ++ ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names), + List.fold_right +- (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) ++ (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam)) + methl cl_init) + + let output_methods tbl methods lam = + match methods with + [] -> lam + | [lab; code] -> +- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam ++ lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam + | _ -> +- lsequence (Lapply(oo_prim "set_methods", +- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) +- lam ++ lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam + + let rec ignore_cstrs cl = + match cl.cl_desc with +@@ -266,7 +265,8 @@ + Llet (Strict, obj_init, + Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: + if top then [Lprim(Pfield 3, [lpath])] else []), +- bind_super cla super cl_init)) ++ bind_super cla super cl_init), ++ [], []) + | _ -> + assert false + end +@@ -278,10 +278,11 @@ + match field with + Cf_inher (cl, vals, meths) -> + let cl_init = output_methods cla methods cl_init in +- let inh_init, cl_init = ++ let (inh_init, cl_init, meths', vals') = + build_class_init cla false + (vals, meths_super cla str.cl_meths meths) + inh_init cl_init msubst top cl in ++ let cl_init = bind_methods cla meths' vals' cl_init in + (inh_init, cl_init, [], values) + | Cf_val (name, id, exp) -> + (inh_init, cl_init, methods, (name, id)::values) +@@ -304,29 +305,37 @@ + (inh_init, cl_init, methods, vals @ values) + | Cf_init exp -> + (inh_init, +- Lsequence(Lapply (oo_prim "add_initializer", +- Lvar cla :: msubst false (transl_exp exp)), ++ Lsequence(lprim "add_initializer" ++ (Lvar cla :: msubst false (transl_exp exp)), + cl_init), + methods, values)) + str.cl_field + (inh_init, cl_init, [], []) + in + let cl_init = output_methods cla methods cl_init in +- (inh_init, bind_methods cla str.cl_meths values cl_init) ++ (* inh_init, bind_methods cla str.cl_meths values cl_init *) ++ let methods = Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in ++ (inh_init, cl_init, methods, values) + | Tclass_fun (pat, vals, cl, _) -> +- let (inh_init, cl_init) = ++ let (inh_init, cl_init, methods, values) = + build_class_init cla cstr super inh_init cl_init msubst top cl + in ++ let fv = free_variables ~ifused:true cl_init in ++ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in + let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in +- (inh_init, transl_vals cla true vals cl_init) ++ (* inh_init, transl_vals cla true vals cl_init *) ++ (inh_init, cl_init, methods, vals @ values) + | Tclass_apply (cl, exprs) -> + build_class_init cla cstr super inh_init cl_init msubst top cl + | Tclass_let (rec_flag, defs, vals, cl) -> +- let (inh_init, cl_init) = ++ let (inh_init, cl_init, methods, values) = + build_class_init cla cstr super inh_init cl_init msubst top cl + in ++ let fv = free_variables ~ifused:true cl_init in ++ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in + let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in +- (inh_init, transl_vals cla true vals cl_init) ++ (* inh_init, transl_vals cla true vals cl_init *) ++ (inh_init, cl_init, methods, vals @ values) + | Tclass_constraint (cl, vals, meths, concr_meths) -> + let virt_meths = + List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in +@@ -358,23 +367,34 @@ + cl_init valids in + (inh_init, + Llet (Strict, inh, +- Lapply(oo_prim "inherits", narrow_args @ +- [lpath; Lconst(Const_pointer(if top then 1 else 0))]), ++ lprim "inherits" ++ (narrow_args @ ++ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), + Llet(StrictOpt, obj_init, lfield inh 0, + Llet(Alias, inh_vals, lfield inh 1, +- Llet(Alias, inh_meths, lfield inh 2, cl_init))))) ++ Llet(Alias, inh_meths, lfield inh 2, cl_init)))), ++ [], []) + | _ -> + let core cl_init = + build_class_init cla true super inh_init cl_init msubst top cl + in + if cstr then core cl_init else +- let (inh_init, cl_init) = +- core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) ++ let (inh_init, cl_init, methods, values) = ++ core (Lsequence (lprim "widen" [Lvar cla], cl_init)) + in +- (inh_init, +- Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init)) ++ let cl_init = bind_methods cla methods values cl_init in ++ (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], []) + end + ++let build_class_init cla env inh_init obj_init msubst top cl = ++ let inh_init = List.rev inh_init in ++ let (inh_init, cl_init, methods, values) = ++ build_class_init cla true ([],[]) inh_init obj_init msubst top cl in ++ assert (inh_init = []); ++ if IdentSet.mem env (free_variables ~ifused:true cl_init) ++ then bind_methods cla methods (("", env) :: values) cl_init ++ else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init) ++ + let rec build_class_lets cl = + match cl.cl_desc with + Tclass_let (rec_flag, defs, vals, cl) -> +@@ -459,16 +479,16 @@ + Strict, new_init, lfunction [obj_init] obj_init', + Llet( + Alias, cla, transl_path path, +- Lprim(Pmakeblock(0, Immutable), +- [Lapply(Lvar new_init, [lfield cla 0]); +- lfunction [table] +- (Llet(Strict, env_init, +- Lapply(lfield cla 1, [Lvar table]), +- lfunction [envs] +- (Lapply(Lvar new_init, +- [Lapply(Lvar env_init, [Lvar envs])])))); +- lfield cla 2; +- lfield cla 3]))) ++ ltuple ++ [Lapply(Lvar new_init, [lfield cla 0]); ++ lfunction [table] ++ (Llet(Strict, env_init, ++ Lapply(lfield cla 1, [Lvar table]), ++ lfunction [envs] ++ (Lapply(Lvar new_init, ++ [Lapply(Lvar env_init, [Lvar envs])])))); ++ lfield cla 2; ++ lfield cla 3])) + with Exit -> + lambda_unit + +@@ -541,7 +561,7 @@ + open CamlinternalOO + let builtin_meths arr self env env2 body = + let builtin, args = builtin_meths self env env2 body in +- if not arr then [Lapply(oo_prim builtin, args)] else ++ if not arr then [lprim builtin args] else + let tag = match builtin with + "get_const" -> GetConst + | "get_var" -> GetVar +@@ -599,7 +619,8 @@ + + (* Prepare for heavy environment handling *) + let tables = Ident.create (Ident.name cl_id ^ "_tables") in +- let (top_env, req) = oo_add_class tables in ++ let table_init = ref None in ++ let (top_env, req) = oo_add_class tables table_init in + let top = not req in + let cl_env, llets = build_class_lets cl in + let new_ids = if top then [] else Env.diff top_env cl_env in +@@ -633,6 +654,7 @@ + begin try + (* Doesn't seem to improve size for bytecode *) + (* if not !Clflags.native_code then raise Not_found; *) ++ if !Clflags.debug then raise Not_found; + builtin_meths arr [self] env env2 (lfunction args body') + with Not_found -> + [lfunction (self :: args) +@@ -665,15 +687,8 @@ + 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 +- in +- assert (inh_init' = []); +- let table = Ident.create "table" +- and class_init = Ident.create (Ident.name cl_id ^ "_init") +- and env_init = Ident.create "env_init" +- and obj_init = Ident.create "obj_init" in ++ let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in ++ let obj_init = Ident.create "obj_init" in + let pub_meths = + List.sort + (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) +@@ -685,42 +700,44 @@ + let name' = List.assoc tag rev_map in + if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) + tags pub_meths; ++ let pos = cl.cl_loc.Location.loc_end in ++ let filepos = [transl_label pos.Lexing.pos_fname; ++ Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in + let ltable table lam = +- Llet(Strict, table, +- Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) ++ Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam) + and ldirect obj_init = + Llet(Strict, obj_init, cl_init, +- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), ++ Lsequence(lprim "init_class_shared" (Lvar cla :: filepos), + Lapply(Lvar obj_init, [lambda_unit]))) + in + (* Simplest case: an object defined at toplevel (ids=[]) *) + if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + ++ let table = Ident.create "table" ++ and class_init = Ident.create (Ident.name cl_id ^ "_init") ++ and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in ++ let cl_init_fun = Lfunction(Curried, [cla], cl_init) in + let concrete = + ids = [] || + Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = [] +- and lclass lam = +- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in ++ and lclass cl_init lam = + Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) + and lbody fv = + if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then +- Lapply (oo_prim "make_class",[transl_meth_list pub_meths; +- Lvar class_init]) ++ lprim "make_class" ++ (transl_meth_list pub_meths :: Lvar class_init :: filepos) + else + ltable table ( + Llet( + Strict, env_init, Lapply(Lvar class_init, [Lvar table]), +- Lsequence( +- Lapply (oo_prim "init_class", [Lvar table]), +- Lprim(Pmakeblock(0, Immutable), +- [Lapply(Lvar env_init, [lambda_unit]); +- Lvar class_init; Lvar env_init; lambda_unit])))) ++ Lsequence(lprim "init_class_shared" (Lvar table :: filepos), ++ ltuple [Lapply(Lvar env_init, [lambda_unit]); ++ Lvar class_init; Lvar env_init; lambda_unit]))) + and lbody_virt lenvs = +- Lprim(Pmakeblock(0, Immutable), +- [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) ++ ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs] + in + (* Still easy: a class defined at toplevel *) +- if top && concrete then lclass lbody else ++ if top && concrete then lclass (llets cl_init_fun) lbody else + if top then llets (lbody_virt lambda_unit) else + + (* Now for the hard stuff: prepare for table cacheing *) +@@ -733,23 +750,16 @@ + let lenv = + let menv = + if !new_ids_meths = [] then lambda_unit else +- Lprim(Pmakeblock(0, Immutable), +- List.map (fun id -> Lvar id) !new_ids_meths) in ++ ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in + if !new_ids_init = [] then menv else +- Lprim(Pmakeblock(0, Immutable), +- menv :: List.map (fun id -> Lvar id) !new_ids_init) ++ ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init) + and linh_envs = + List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) + (List.rev inh_init) + in + let make_envs lam = + Llet(StrictOpt, envs, +- (if linh_envs = [] then lenv else +- Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)), +- lam) +- and def_ids cla lam = +- Llet(StrictOpt, env2, +- Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]), ++ (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)), + lam) + in + let inh_paths = +@@ -757,46 +767,53 @@ + (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in + let inh_keys = + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in +- let lclass lam = +- Llet(Strict, class_init, +- Lfunction(Curried, [cla], def_ids cla cl_init), lam) ++ let lclass_init lam = ++ Llet(Strict, class_init, cl_init_fun, lam) + and lcache lam = + if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else +- Llet(Strict, cached, +- Lapply(oo_prim "lookup_tables", +- [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), ++ Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys], + lam) + and lset cached i lam = + Lprim(Psetfield(i, true), [Lvar cached; lam]) + in +- let ldirect () = +- ltable cla +- (Llet(Strict, env_init, def_ids cla cl_init, +- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), +- lset cached 0 (Lvar env_init)))) +- and lclass_virt () = +- lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) ++ let ldirect prim pos = ++ ltable cla ( ++ Llet(Strict, env_init, cl_init, ++ Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init))) ++ and lclass_concrete cached = ++ ltuple [Lapply (lfield cached 0, [lenvs]); ++ lfield cached 1; lfield cached 0; lenvs] + in ++ + llets ( +- lcache ( +- Lsequence( +- Lifthenelse(lfield cached 0, lambda_unit, +- if ids = [] then ldirect () else +- if not concrete then lclass_virt () else +- lclass ( +- Lapply (oo_prim "make_class_store", +- [transl_meth_list pub_meths; +- Lvar class_init; Lvar cached]))), + make_envs ( +- if ids = [] then Lapply(lfield cached 0, [lenvs]) else +- Lprim(Pmakeblock(0, Immutable), +- if concrete then +- [Lapply(lfield cached 0, [lenvs]); +- lfield cached 1; +- lfield cached 0; +- lenvs] +- else [lambda_unit; lfield cached 0; lambda_unit; lenvs] +- ))))) ++ if inh_paths = [] && concrete then ++ if ids = [] then begin ++ table_init := Some (ldirect "init_class_shared" filepos); ++ Lapply (Lvar tables, [lenvs]) ++ end else begin ++ let init = ++ lclass cl_init_fun (fun _ -> ++ lprim "make_class_env" ++ (transl_meth_list pub_meths :: Lvar class_init :: filepos)) ++ in table_init := Some init; ++ lclass_concrete tables ++ end ++ else begin ++ lcache ( ++ Lsequence( ++ Lifthenelse(lfield cached 0, lambda_unit, ++ if ids = [] then lset cached 0 (ldirect "init_class" []) else ++ if not concrete then lset cached 0 cl_init_fun else ++ lclass_init ( ++ lprim "make_class_store" ++ [transl_meth_list pub_meths; Lvar class_init; Lvar cached])), ++ llets ( ++ make_envs ( ++ if ids = [] then Lapply(lfield cached 0, [lenvs]) else ++ if concrete then lclass_concrete cached else ++ ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs])))) ++ end)) + + (* Wrapper for class compilation *) + +Index: bytecomp/translobj.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v +retrieving revision 1.9 +diff -u -r1.9 translobj.ml +--- bytecomp/translobj.ml 26 May 2004 11:10:51 -0000 1.9 ++++ bytecomp/translobj.ml 2 Feb 2006 05:08:56 -0000 +@@ -88,7 +88,6 @@ + + (* Insert labels *) + +-let string s = Lconst (Const_base (Const_string s)) + let int n = Lconst (Const_base (Const_int n)) + + let prim_makearray = +@@ -124,8 +123,8 @@ + let top_env = ref Env.empty + let classes = ref [] + +-let oo_add_class id = +- classes := id :: !classes; ++let oo_add_class id init = ++ classes := (id, init) :: !classes; + (!top_env, !cache_required) + + let oo_wrap env req f x = +@@ -141,10 +140,12 @@ + let lambda = f x in + let lambda = + List.fold_left +- (fun lambda id -> ++ (fun lambda (id, init) -> + Llet(StrictOpt, id, +- Lprim(Pmakeblock(0, Mutable), +- [lambda_unit; lambda_unit; lambda_unit]), ++ (match !init with ++ Some lam -> lam ++ | None -> Lprim(Pmakeblock(0, Mutable), ++ [lambda_unit; lambda_unit; lambda_unit])), + lambda)) + lambda !classes + in +Index: bytecomp/translobj.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v +retrieving revision 1.6 +diff -u -r1.6 translobj.mli +--- bytecomp/translobj.mli 26 May 2004 11:10:51 -0000 1.6 ++++ bytecomp/translobj.mli 2 Feb 2006 05:08:56 -0000 +@@ -25,4 +25,4 @@ + Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda + + val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda +-val oo_add_class: Ident.t -> Env.t * bool ++val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool +Index: byterun/compare.h +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v +retrieving revision 1.2 +diff -u -r1.2 compare.h +--- byterun/compare.h 31 Dec 2003 14:20:35 -0000 1.2 ++++ byterun/compare.h 2 Feb 2006 05:08:56 -0000 +@@ -17,5 +17,6 @@ + #define CAML_COMPARE_H + + CAMLextern int caml_compare_unordered; ++CAMLextern value caml_compare(value, value); + + #endif /* CAML_COMPARE_H */ +Index: byterun/extern.c +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v +retrieving revision 1.59 +diff -u -r1.59 extern.c +--- byterun/extern.c 4 Jan 2006 16:55:49 -0000 1.59 ++++ byterun/extern.c 2 Feb 2006 05:08:56 -0000 +@@ -411,6 +411,22 @@ + extern_record_location(v); + break; + } ++ case Object_tag: { ++ value field0; ++ mlsize_t i; ++ i = Wosize_val(Field(v, 0)) - 1; ++ field0 = Field(Field(v, 0),i); ++ if (Wosize_val(field0) > 0) { ++ writecode32(CODE_OBJECT, Wosize_hd (hd)); ++ extern_record_location(v); ++ extern_rec(field0); ++ for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i)); ++ v = Field(v, i); ++ goto tailcall; ++ } ++ if (!extern_closures) ++ extern_invalid_argument("output_value: dynamic class"); ++ } /* may fall through */ + default: { + value field0; + mlsize_t i; +Index: byterun/intern.c +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v +retrieving revision 1.60 +diff -u -r1.60 intern.c +--- byterun/intern.c 22 Sep 2005 14:21:50 -0000 1.60 ++++ byterun/intern.c 2 Feb 2006 05:08:56 -0000 +@@ -28,6 +28,8 @@ + #include "mlvalues.h" + #include "misc.h" + #include "reverse.h" ++#include "callback.h" ++#include "compare.h" + + static unsigned char * intern_src; + /* Reading pointer in block holding input data. */ +@@ -98,6 +100,25 @@ + #define readblock(dest,len) \ + (memmove((dest), intern_src, (len)), intern_src += (len)) + ++static value get_method_table (value key) ++{ ++ static value *classes = NULL; ++ value current; ++ if (classes == NULL) { ++ classes = caml_named_value("caml_oo_classes"); ++ if (classes == NULL) return 0; ++ caml_register_global_root(classes); ++ } ++ for (current = Field(*classes, 0); Is_block(current); ++ current = Field(current, 1)) ++ { ++ value head = Field(current, 0); ++ if (caml_compare(key, Field(head, 0)) == Val_int(0)) ++ return Field(head, 1); ++ } ++ return 0; ++} ++ + static void intern_cleanup(void) + { + if (intern_input_malloced) caml_stat_free(intern_input); +@@ -315,6 +336,24 @@ + Custom_ops_val(v) = ops; + intern_dest += 1 + size; + break; ++ case CODE_OBJECT: ++ size = read32u(); ++ v = Val_hp(intern_dest); ++ *dest = v; ++ if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; ++ dest = (value *) (intern_dest + 1); ++ *intern_dest = Make_header(size, Object_tag, intern_color); ++ intern_dest += 1 + size; ++ intern_rec(dest); ++ *dest = get_method_table(*dest); ++ if (*dest == 0) { ++ intern_cleanup(); ++ caml_failwith("input_value: unknown class"); ++ } ++ for(size--, dest++; size > 1; size--, dest++) ++ intern_rec(dest); ++ goto tailcall; ++ + default: + intern_cleanup(); + caml_failwith("input_value: ill-formed message"); +Index: byterun/intext.h +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v +retrieving revision 1.32 +diff -u -r1.32 intext.h +--- byterun/intext.h 22 Sep 2005 14:21:50 -0000 1.32 ++++ byterun/intext.h 2 Feb 2006 05:08:56 -0000 +@@ -56,6 +56,7 @@ + #define CODE_CODEPOINTER 0x10 + #define CODE_INFIXPOINTER 0x11 + #define CODE_CUSTOM 0x12 ++#define CODE_OBJECT 0x14 + + #if ARCH_FLOAT_ENDIANNESS == 0x76543210 + #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG +Index: stdlib/camlinternalOO.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v +retrieving revision 1.14 +diff -u -r1.14 camlinternalOO.ml +--- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14 ++++ stdlib/camlinternalOO.ml 2 Feb 2006 05:08:56 -0000 +@@ -305,10 +305,38 @@ + public_methods; + table + ++(* ++let create_table_variables pub_meths priv_meths vars = ++ let tbl = create_table pub_meths in ++ let pub_meths = to_array pub_meths ++ and priv_meths = to_array priv_meths ++ and vars = to_array vars in ++ let len = 2 + Array.length pub_meths + Array.length priv_meths in ++ let res = Array.create len tbl in ++ let mv = new_methods_variables tbl pub_meths vars in ++ Array.blit mv 0 res 1; ++ res ++*) ++ + let init_class table = + inst_var_count := !inst_var_count + table.size - 1; + table.initializers <- List.rev table.initializers; +- resize table (3 + magic table.methods.(1) * 16 / Sys.word_size) ++ let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in ++ (* keep 1 more for extra info *) ++ let len = if len > Array.length table.methods then len else len+1 in ++ resize table len ++ ++let classes = ref [] ++let () = Callback.register "caml_oo_classes" classes ++ ++let init_class_shared table (file : string) (pos : int) = ++ init_class table; ++ let rec unique_pos pos = ++ if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000) ++ else pos in ++ let pos = unique_pos pos in ++ table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos); ++ classes := ((file, pos), table.methods) :: !classes + + let inherits cla vals virt_meths concr_meths (_, super, _, env) top = + narrow cla vals virt_meths concr_meths; +@@ -319,12 +347,18 @@ + Array.map (fun nm -> get_method cla (get_method_label cla nm)) + (to_array concr_meths)) + +-let make_class pub_meths class_init = ++let make_class pub_meths class_init file pos = + let table = create_table pub_meths in + let env_init = class_init table in +- init_class table; ++ init_class_shared table file pos; + (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0) + ++let make_class_env pub_meths class_init file pos = ++ let table = create_table pub_meths in ++ let env_init = class_init table in ++ init_class_shared table file pos; ++ (env_init, class_init) ++ + type init_table = { mutable env_init: t; mutable class_init: table -> t } + + let make_class_store pub_meths class_init init_table = +Index: stdlib/camlinternalOO.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v +retrieving revision 1.9 +diff -u -r1.9 camlinternalOO.mli +--- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9 ++++ stdlib/camlinternalOO.mli 2 Feb 2006 05:08:56 -0000 +@@ -43,14 +43,20 @@ + val add_initializer : table -> (obj -> unit) -> unit + val dummy_table : table + val create_table : string array -> table ++(* val create_table_variables : ++ string array -> string array -> string array -> table *) + val init_class : table -> unit ++val init_class_shared : table -> string -> int -> unit + val inherits : + table -> string array -> string array -> string array -> + (t * (table -> obj -> Obj.t) * t * obj) -> bool -> + (Obj.t * int array * closure array) + val make_class : +- string array -> (table -> Obj.t -> t) -> ++ string array -> (table -> Obj.t -> t) -> string -> int -> + (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) ++val make_class_env : ++ string array -> (table -> Obj.t -> t) -> string -> int -> ++ (Obj.t -> t) * (table -> Obj.t -> t) + type init_table + val make_class_store : + string array -> (table -> t) -> init_table -> unit diff --git a/experimental/garrigue/module-errors.diffs b/experimental/garrigue/module-errors.diffs new file mode 100644 index 00000000..2f8c2bc2 --- /dev/null +++ b/experimental/garrigue/module-errors.diffs @@ -0,0 +1,403 @@ +Index: typing/includemod.ml +=================================================================== +--- typing/includemod.ml (revision 11161) ++++ typing/includemod.ml (working copy) +@@ -19,7 +19,7 @@ + open Types + open Typedtree + +-type error = ++type symptom = + Missing_field of Ident.t + | Value_descriptions of Ident.t * value_description * value_description + | Type_declarations of Ident.t * type_declaration +@@ -38,6 +38,10 @@ + Ctype.class_match_failure list + | Unbound_modtype_path of Path.t + ++type pos = ++ Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t ++type error = pos list * symptom ++ + exception Error of error list + + (* All functions "blah env x1 x2" check that x1 is included in x2, +@@ -46,51 +50,52 @@ + + (* Inclusion between value descriptions *) + +-let value_descriptions env subst id vd1 vd2 = ++let value_descriptions env cxt subst id vd1 vd2 = + let vd2 = Subst.value_description subst vd2 in + try + Includecore.value_descriptions env vd1 vd2 + with Includecore.Dont_match -> +- raise(Error[Value_descriptions(id, vd1, vd2)]) ++ raise(Error[cxt, Value_descriptions(id, vd1, vd2)]) + + (* Inclusion between type declarations *) + +-let type_declarations env subst id decl1 decl2 = ++let type_declarations env cxt subst id decl1 decl2 = + let decl2 = Subst.type_declaration subst decl2 in + let err = Includecore.type_declarations env id decl1 decl2 in +- if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)]) ++ if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)]) + + (* Inclusion between exception declarations *) + +-let exception_declarations env subst id decl1 decl2 = ++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[Exception_declarations(id, decl1, decl2)]) ++ else raise(Error[cxt, Exception_declarations(id, decl1, decl2)]) + + (* Inclusion between class declarations *) + +-let class_type_declarations env subst id decl1 decl2 = ++let class_type_declarations env cxt subst id decl1 decl2 = + let decl2 = Subst.cltype_declaration subst decl2 in + match Includeclass.class_type_declarations env decl1 decl2 with + [] -> () +- | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)]) ++ | reason -> ++ raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)]) + +-let class_declarations env subst id decl1 decl2 = ++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[Class_declarations(id, decl1, decl2, reason)]) ++ | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)]) + + (* Expand a module type identifier when possible *) + + exception Dont_match + +-let expand_module_path env path = ++let expand_module_path env cxt path = + try + Env.find_modtype_expansion path env + with Not_found -> +- raise(Error[Unbound_modtype_path path]) ++ raise(Error[cxt, Unbound_modtype_path path]) + + (* Extract name, kind and ident from a signature item *) + +@@ -128,28 +133,29 @@ + Return the restriction that transforms a value of the smaller type + into a value of the bigger type. *) + +-let rec modtypes env subst mty1 mty2 = ++let rec modtypes env cxt subst mty1 mty2 = + try +- try_modtypes env subst mty1 mty2 ++ try_modtypes env cxt subst mty1 mty2 + with + Dont_match -> +- raise(Error[Module_types(mty1, Subst.modtype subst mty2)]) ++ raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)]) + | Error reasons -> +- raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons)) ++ raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2)) ++ :: reasons)) + +-and try_modtypes env subst mty1 mty2 = ++and try_modtypes env cxt subst mty1 mty2 = + match (mty1, mty2) with + (_, Tmty_ident p2) -> +- try_modtypes2 env mty1 (Subst.modtype subst mty2) ++ try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) + | (Tmty_ident p1, _) -> +- try_modtypes env subst (expand_module_path env p1) mty2 ++ try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 + | (Tmty_signature sig1, Tmty_signature sig2) -> +- signatures env subst sig1 sig2 ++ signatures env cxt subst sig1 sig2 + | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) -> + let arg2' = Subst.modtype subst arg2 in +- let cc_arg = modtypes env Subst.identity arg2' arg1 in ++ let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in + let cc_res = +- modtypes (Env.add_module param1 arg2' env) ++ modtypes (Env.add_module param1 arg2' env) (Body param1::cxt) + (Subst.add_module param2 (Pident param1) subst) res1 res2 in + begin match (cc_arg, cc_res) with + (Tcoerce_none, Tcoerce_none) -> Tcoerce_none +@@ -158,19 +164,19 @@ + | (_, _) -> + raise Dont_match + +-and try_modtypes2 env mty1 mty2 = ++and try_modtypes2 env cxt mty1 mty2 = + (* mty2 is an identifier *) + match (mty1, mty2) with + (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 -> + Tcoerce_none + | (_, Tmty_ident p2) -> +- try_modtypes env Subst.identity mty1 (expand_module_path env p2) ++ try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2) + | (_, _) -> + assert false + + (* Inclusion between signatures *) + +-and signatures env subst sig1 sig2 = ++and signatures env cxt subst sig1 sig2 = + (* Environment used to check inclusion of components *) + let new_env = + Env.add_signature sig1 env in +@@ -202,7 +208,7 @@ + let rec pair_components subst paired unpaired = function + [] -> + begin match unpaired with +- [] -> signature_components new_env subst (List.rev paired) ++ [] -> signature_components new_env cxt subst (List.rev paired) + | _ -> raise(Error unpaired) + end + | item2 :: rem -> +@@ -234,7 +240,7 @@ + ((item1, item2, pos1) :: paired) unpaired rem + with Not_found -> + let unpaired = +- if report then Missing_field id2 :: unpaired else unpaired in ++ if report then (cxt, 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 *) +@@ -242,65 +248,67 @@ + + (* Inclusion between signature components *) + +-and signature_components env subst = function ++and signature_components env cxt subst = function + [] -> [] + | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem -> +- let cc = value_descriptions env subst id1 valdecl1 valdecl2 in ++ let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in + begin match valdecl2.val_kind with +- Val_prim p -> signature_components env subst rem +- | _ -> (pos, cc) :: signature_components env subst rem ++ Val_prim p -> signature_components env cxt subst rem ++ | _ -> (pos, cc) :: signature_components env cxt subst rem + end + | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem -> +- type_declarations env subst id1 tydecl1 tydecl2; +- signature_components env subst rem ++ type_declarations env cxt subst id1 tydecl1 tydecl2; ++ signature_components env cxt subst rem + | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos) + :: rem -> +- exception_declarations env subst id1 excdecl1 excdecl2; +- (pos, Tcoerce_none) :: signature_components env subst rem ++ exception_declarations env cxt subst id1 excdecl1 excdecl2; ++ (pos, Tcoerce_none) :: signature_components env cxt subst rem + | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem -> + let cc = +- modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in +- (pos, cc) :: signature_components env subst rem ++ modtypes env (Module id1::cxt) subst ++ (Mtype.strengthen env mty1 (Pident id1)) mty2 in ++ (pos, cc) :: signature_components env cxt subst rem + | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem -> +- modtype_infos env subst id1 info1 info2; +- signature_components env subst rem ++ modtype_infos env cxt subst id1 info1 info2; ++ signature_components env cxt subst rem + | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem -> +- class_declarations env subst id1 decl1 decl2; +- (pos, Tcoerce_none) :: signature_components env subst rem ++ class_declarations env cxt subst id1 decl1 decl2; ++ (pos, Tcoerce_none) :: signature_components env cxt subst rem + | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem -> +- class_type_declarations env subst id1 info1 info2; +- signature_components env subst rem ++ class_type_declarations env cxt subst id1 info1 info2; ++ signature_components env cxt subst rem + | _ -> + assert false + + (* Inclusion between module type specifications *) + +-and modtype_infos env subst id info1 info2 = ++and modtype_infos env cxt subst id info1 info2 = + let info2 = Subst.modtype_declaration subst info2 in ++ let cxt' = Modtype id :: cxt in + try + match (info1, info2) with + (Tmodtype_abstract, Tmodtype_abstract) -> () + | (Tmodtype_manifest mty1, Tmodtype_abstract) -> () + | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) -> +- check_modtype_equiv env mty1 mty2 ++ check_modtype_equiv env cxt' mty1 mty2 + | (Tmodtype_abstract, Tmodtype_manifest mty2) -> +- check_modtype_equiv env (Tmty_ident(Pident id)) mty2 ++ check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2 + with Error reasons -> +- raise(Error(Modtype_infos(id, info1, info2) :: reasons)) ++ raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons)) + +-and check_modtype_equiv env mty1 mty2 = ++and check_modtype_equiv env cxt mty1 mty2 = + match +- (modtypes env Subst.identity mty1 mty2, +- modtypes env Subst.identity mty2 mty1) ++ (modtypes env cxt Subst.identity mty1 mty2, ++ modtypes env cxt Subst.identity mty2 mty1) + with + (Tcoerce_none, Tcoerce_none) -> () +- | (_, _) -> raise(Error [Modtype_permutation]) ++ | (_, _) -> raise(Error [cxt, Modtype_permutation]) + + (* Simplified inclusion check between module types (for Env) *) + + let check_modtype_inclusion env mty1 path1 mty2 = + try +- ignore(modtypes env Subst.identity ++ ignore(modtypes env [] Subst.identity + (Mtype.strengthen env mty1 path1) mty2) + with Error reasons -> + raise Not_found +@@ -312,16 +320,16 @@ + + let compunit impl_name impl_sig intf_name intf_sig = + try +- signatures Env.initial Subst.identity impl_sig intf_sig ++ signatures Env.initial [] Subst.identity impl_sig intf_sig + with Error reasons -> +- raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons)) ++ raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons)) + +-(* Hide the substitution parameter to the outside world *) ++(* Hide the context and substitution parameters to the outside world *) + +-let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2 +-let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2 ++let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2 ++let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 + let type_declarations env id decl1 decl2 = +- type_declarations env Subst.identity id decl1 decl2 ++ type_declarations env [] Subst.identity id decl1 decl2 + + (* Error report *) + +@@ -384,9 +392,62 @@ + | Unbound_modtype_path path -> + fprintf ppf "Unbound module type %a" Printtyp.path path + +-let report_error ppf = function +- | [] -> () +- | err :: errs -> +- let print_errs ppf errs = +- List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in +- fprintf ppf "@[%a%a@]" include_err err print_errs errs ++let rec context ppf = function ++ Module id :: rem -> ++ fprintf ppf "@[<2>module %a%a@]" ident id args rem ++ | Modtype id :: rem -> ++ fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem ++ | Body x :: rem -> ++ fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem ++ | Arg x :: rem -> ++ fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem ++ | [] -> ++ fprintf ppf "" ++and context_mty ppf = function ++ (Module _ | Modtype _) :: _ as rem -> ++ fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem ++ | cxt -> context ppf cxt ++and args ppf = function ++ Body x :: rem -> ++ fprintf ppf "(%a)%a" ident x args rem ++ | Arg x :: rem -> ++ fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem ++ | cxt -> ++ fprintf ppf " :@ %a" context_mty cxt ++ ++let path_of_context = function ++ Module id :: rem -> ++ let rec subm path = function ++ [] -> path ++ | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem ++ | _ -> assert false ++ in subm (Pident id) rem ++ | _ -> assert false ++ ++let context ppf cxt = ++ if cxt = [] then () else ++ if List.for_all (function Module _ -> true | _ -> false) cxt then ++ fprintf ppf "In module %a:@ " path (path_of_context 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 max_size = 500 ++let buffer = String.create max_size ++let is_big obj = ++ try ignore (Marshal.to_buffer buffer 0 max_size obj []); false ++ with _ -> true ++ ++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 !Clflags.show_trace || not (is_big err) 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 ++ fprintf ppf "@[%a%a@]" print_errs errs include_err err +Index: typing/includemod.mli +=================================================================== +--- typing/includemod.mli (revision 11161) ++++ typing/includemod.mli (working copy) +@@ -24,7 +24,7 @@ + val type_declarations: + Env.t -> Ident.t -> type_declaration -> type_declaration -> unit + +-type error = ++type symptom = + Missing_field of Ident.t + | Value_descriptions of Ident.t * value_description * value_description + | Type_declarations of Ident.t * type_declaration +@@ -43,6 +43,10 @@ + Ctype.class_match_failure list + | Unbound_modtype_path of Path.t + ++type pos = ++ Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t ++type error = pos list * symptom ++ + exception Error of error list + + val report_error: formatter -> error list -> unit +Index: utils/clflags.ml +=================================================================== +--- utils/clflags.ml (revision 11161) ++++ utils/clflags.ml (working copy) +@@ -53,6 +53,7 @@ + and dllpaths = ref ([] : string list) (* -dllpath *) + and make_package = ref false (* -pack *) + and for_package = ref (None: string option) (* -for-pack *) ++and show_trace = ref false (* -show-trace *) + let dump_parsetree = ref false (* -dparsetree *) + and dump_rawlambda = ref false (* -drawlambda *) + and dump_lambda = ref false (* -dlambda *) +Index: utils/clflags.mli +=================================================================== +--- utils/clflags.mli (revision 11161) ++++ utils/clflags.mli (working copy) +@@ -50,6 +50,7 @@ + val dllpaths : string list ref + val make_package : bool ref + val for_package : string option ref ++val show_trace : bool ref + val dump_parsetree : bool ref + val dump_rawlambda : bool ref + val dump_lambda : bool ref diff --git a/experimental/garrigue/multimatch.diffs b/experimental/garrigue/multimatch.diffs new file mode 100644 index 00000000..6eb34b72 --- /dev/null +++ b/experimental/garrigue/multimatch.diffs @@ -0,0 +1,1418 @@ +Index: parsing/lexer.mll +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v +retrieving revision 1.73 +diff -u -r1.73 lexer.mll +--- parsing/lexer.mll 11 Apr 2005 16:44:26 -0000 1.73 ++++ parsing/lexer.mll 2 Feb 2006 06:28:32 -0000 +@@ -63,6 +63,8 @@ + "match", MATCH; + "method", METHOD; + "module", MODULE; ++ "multifun", MULTIFUN; ++ "multimatch", MULTIMATCH; + "mutable", MUTABLE; + "new", NEW; + "object", OBJECT; +Index: parsing/parser.mly +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v +retrieving revision 1.123 +diff -u -r1.123 parser.mly +--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123 ++++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000 +@@ -257,6 +257,8 @@ + %token MINUSDOT + %token MINUSGREATER + %token MODULE ++%token MULTIFUN ++%token MULTIMATCH + %token MUTABLE + %token NATIVEINT + %token NEW +@@ -325,7 +327,7 @@ + %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ + %nonassoc LET /* above SEMI ( ...; let ... in ...) */ + %nonassoc below_WITH +-%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ ++%nonassoc FUNCTION WITH MULTIFUN /* below BAR (match ... with ...) */ + %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ + %nonassoc THEN /* below ELSE (if ... then ...) */ + %nonassoc ELSE /* (if ... then ... else ...) */ +@@ -804,8 +806,12 @@ + { mkexp(Pexp_function("", None, List.rev $3)) } + | FUN labeled_simple_pattern fun_def + { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) } ++ | MULTIFUN opt_bar match_cases ++ { mkexp(Pexp_multifun(List.rev $3)) } + | MATCH seq_expr WITH opt_bar match_cases +- { mkexp(Pexp_match($2, List.rev $5)) } ++ { mkexp(Pexp_match($2, List.rev $5, false)) } ++ | MULTIMATCH seq_expr WITH opt_bar match_cases ++ { mkexp(Pexp_match($2, List.rev $5, true)) } + | TRY seq_expr WITH opt_bar match_cases + { mkexp(Pexp_try($2, List.rev $5)) } + | TRY seq_expr WITH error +@@ -1318,10 +1324,10 @@ + | simple_core_type2 { Rinherit $1 } + ; + tag_field: +- name_tag OF opt_ampersand amper_type_list +- { Rtag ($1, $3, List.rev $4) } +- | name_tag +- { Rtag ($1, true, []) } ++ name_tag OF opt_ampersand amper_type_list amper_type_pair_list ++ { Rtag ($1, $3, List.rev $4, $5) } ++ | name_tag amper_type_pair_list ++ { Rtag ($1, true, [], $2) } + ; + opt_ampersand: + AMPERSAND { true } +@@ -1331,6 +1337,11 @@ + core_type { [$1] } + | amper_type_list AMPERSAND core_type { $3 :: $1 } + ; ++amper_type_pair_list: ++ AMPERSAND core_type EQUAL core_type amper_type_pair_list ++ { ($2, $4) :: $5 } ++ | /* empty */ ++ { [] } + opt_present: + LBRACKETGREATER name_tag_list RBRACKET { List.rev $2 } + | /* empty */ { [] } +Index: parsing/parsetree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v +retrieving revision 1.42 +diff -u -r1.42 parsetree.mli +--- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42 ++++ parsing/parsetree.mli 2 Feb 2006 06:28:32 -0000 +@@ -43,7 +43,7 @@ + | Pfield_var + + and row_field = +- Rtag of label * bool * core_type list ++ Rtag of label * bool * core_type list * (core_type * core_type) list + | Rinherit of core_type + + (* XXX Type expressions for the class language *) +@@ -86,7 +86,7 @@ + | 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_match of expression * (pattern * expression) list * bool + | Pexp_try of expression * (pattern * expression) list + | Pexp_tuple of expression list + | Pexp_construct of Longident.t * expression option * bool +@@ -111,6 +111,7 @@ + | Pexp_lazy of expression + | Pexp_poly of expression * core_type option + | Pexp_object of class_structure ++ | Pexp_multifun of (pattern * expression) list + + (* Value descriptions *) + +Index: parsing/printast.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v +retrieving revision 1.29 +diff -u -r1.29 printast.ml +--- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29 ++++ parsing/printast.ml 2 Feb 2006 06:28:32 -0000 +@@ -205,10 +205,14 @@ + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; +- | Pexp_match (e, l) -> ++ | Pexp_match (e, l, b) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; ++ bool i ppf b ++ | Pexp_multifun l -> ++ line i ppf "Pexp_multifun\n"; ++ list i pattern_x_expression_case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; +@@ -653,7 +657,7 @@ + + and label_x_bool_x_core_type_list i ppf x = + match x with +- Rtag (l, b, ctl) -> ++ Rtag (l, b, ctl, cstr) -> + line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + list (i+1) core_type ppf ctl + | Rinherit (ct) -> +Index: typing/btype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v +retrieving revision 1.38 +diff -u -r1.38 btype.ml +--- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38 ++++ typing/btype.ml 2 Feb 2006 06:28:32 -0000 +@@ -66,16 +66,16 @@ + Clink r when !r <> Cunknown -> commu_repr !r + | c -> c + +-let rec row_field_repr_aux tl = function +- Reither(_, tl', _, {contents = Some fi}) -> +- row_field_repr_aux (tl@tl') fi +- | Reither(c, tl', m, r) -> +- Reither(c, tl@tl', m, r) ++let rec row_field_repr_aux tl tl2 = function ++ Reither(_, tl', _, tl2', {contents = Some fi}) -> ++ row_field_repr_aux (tl@tl') (tl2@tl2') fi ++ | Reither(c, tl', m, tl2', r) -> ++ Reither(c, tl@tl', m, tl2@tl2', r) + | Rpresent (Some _) when tl <> [] -> + Rpresent (Some (List.hd tl)) + | fi -> fi + +-let row_field_repr fi = row_field_repr_aux [] fi ++let row_field_repr fi = row_field_repr_aux [] [] fi + + let rec rev_concat l ll = + match ll with +@@ -170,7 +170,8 @@ + (fun (_, fi) -> + match row_field_repr fi with + | Rpresent(Some ty) -> f ty +- | Reither(_, tl, _, _) -> List.iter f tl ++ | Reither(_, tl, _, tl2, _) -> ++ List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2 + | _ -> ()) + row.row_fields; + match (repr row.row_more).desc with +@@ -208,15 +209,17 @@ + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent(Some ty) -> Rpresent(Some(f ty)) +- | Reither(c, tl, m, e) -> ++ | Reither(c, tl, m, tpl, e) -> + let e = if keep then e else ref None in + let m = if row.row_fixed then fixed else m in + let tl = List.map f tl in ++ let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl ++ and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in + bound := List.filter + (function {desc=Tconstr(_,[],_)} -> false | _ -> true) +- (List.map repr tl) ++ (List.map repr tl @ tl1 @ tl2) + @ !bound; +- Reither(c, tl, m, e) ++ Reither(c, tl, m, List.combine tl1 tl2, e) + | _ -> fi) + row.row_fields in + let name = +Index: typing/ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.200 +diff -u -r1.200 ctype.ml +--- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200 ++++ typing/ctype.ml 2 Feb 2006 06:28:32 -0000 +@@ -340,7 +340,7 @@ + let fi = filter_row_fields erase fi in + match row_field_repr f with + Rabsent -> fi +- | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi ++ | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi + | _ -> p :: fi + + (**************************************) +@@ -1286,6 +1286,10 @@ + + module TypeMap = Map.Make (TypeOps) + ++ ++(* A list of univars which may appear free in a type, but only if generic *) ++let allowed_univars = ref TypeSet.empty ++ + (* Test the occurence of free univars in a type *) + (* that's way too expansive. Must do some kind of cacheing *) + let occur_univar env ty = +@@ -1307,7 +1311,12 @@ + then + match ty.desc with + Tunivar -> +- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()]) ++ if TypeSet.mem ty bound then () else ++ if TypeSet.mem ty !allowed_univars && ++ (ty.level = generic_level || ++ ty.level = pivot_level - generic_level) ++ then () ++ else raise (Unify [ty, newgenvar()]) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + occur_rec bound ty +@@ -1393,6 +1402,7 @@ + with exn -> univar_pairs := old_univars; raise exn + + let univar_pairs = ref [] ++let delayed_conditionals = ref [] + + + (*****************) +@@ -1691,9 +1701,11 @@ + with Not_found -> (h,l)::hl) + (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields) + (List.map fst r2)); ++ let fixed1 = row1.row_fixed || rm1.desc <> Tvar ++ and fixed2 = row2.row_fixed || rm2.desc <> Tvar in + let more = +- if row1.row_fixed then rm1 else +- if row2.row_fixed then rm2 else ++ if fixed1 then rm1 else ++ if fixed2 then rm2 else + newgenvar () + in update_level env (min rm1.level rm2.level) more; + let fixed = row1.row_fixed || row2.row_fixed +@@ -1726,18 +1738,18 @@ + let bound = row1.row_bound @ row2.row_bound in + let row0 = {row_fields = []; row_more = more; row_bound = bound; + row_closed = closed; row_fixed = fixed; row_name = name} in +- let set_more row rest = ++ let set_more row row_fixed rest = + let rest = + if closed then + filter_row_fields row.row_closed rest + else rest in +- if rest <> [] && (row.row_closed || row.row_fixed) +- || closed && row.row_fixed && not row.row_closed then begin ++ if rest <> [] && (row.row_closed || row_fixed) ++ || closed && row_fixed && not row.row_closed then begin + let t1 = mkvariant [] true and t2 = mkvariant rest false in + raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) + end; + let rm = row_more row in +- if row.row_fixed then ++ if row_fixed then + if row0.row_more == rm then () else + if rm.desc = Tvar then link_type rm row0.row_more else + unify env rm row0.row_more +@@ -1748,11 +1760,11 @@ + in + let md1 = rm1.desc and md2 = rm2.desc in + begin try +- set_more row1 r2; +- set_more row2 r1; ++ set_more row1 fixed1 r2; ++ set_more row2 fixed2 r1; + List.iter + (fun (l,f1,f2) -> +- try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2 ++ try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 + with Unify trace -> + raise (Unify ((mkvariant [l,f1] true, + mkvariant [l,f2] true) :: trace))) +@@ -1761,13 +1773,13 @@ + log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn + end + +-and unify_row_field env fixed1 fixed2 l f1 f2 = ++and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 = + let f1 = row_field_repr f1 and f2 = row_field_repr f2 in + if f1 == f2 then () else + match f1, f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () +- | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> ++ | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) -> + if e1 == e2 then () else + let redo = + (m1 || m2) && +@@ -1777,32 +1789,70 @@ + List.iter (unify env t1) tl; + !e1 <> None || !e2 <> None + end in +- if redo then unify_row_field env fixed1 fixed2 l f1 f2 else ++ let redo = ++ redo || begin ++ if tp1 = [] && fixed1 then unify_pairs env tp2; ++ if tp2 = [] && fixed2 then unify_pairs env tp1; ++ !e1 <> None || !e2 <> None ++ end ++ in ++ if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else + let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in + let rec remq tl = function [] -> [] + | ty :: tl' -> + if List.memq ty tl then remq tl tl' else ty :: remq tl tl' + in + let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in ++ let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in ++ let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in ++ let rec rempq tp = function [] -> [] ++ | (t1,t2 as p) :: tp' -> ++ if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then ++ rempq tp tp' ++ else p :: rempq tp tp' ++ in ++ let tp1' = ++ if fixed2 then begin ++ delayed_conditionals := ++ (!univar_pairs, tp1, l, row2) :: !delayed_conditionals; ++ [] ++ end else rempq tp2 tp1 ++ and tp2' = ++ if fixed1 then begin ++ delayed_conditionals := ++ (!univar_pairs, tp2, l, row1) :: !delayed_conditionals; ++ [] ++ end else rempq tp1 tp2 ++ in + let e = ref None in +- let f1' = Reither(c1 || c2, tl1', m1 || m2, e) +- and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in +- set_row_field e1 f1'; set_row_field e2 f2'; +- | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2 +- | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1 ++ let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e) ++ and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in ++ set_row_field e1 f1'; set_row_field e2 f2' ++ | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2 ++ | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1 + | Rabsent, Rabsent -> () +- | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> ++ | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 -> + set_row_field e1 f2; +- (try List.iter (fun t1 -> unify env t1 t2) tl ++ begin try ++ List.iter (fun t1 -> unify env t1 t2) tl; ++ List.iter (fun (t1,t2) -> unify env t1 t2) tp ++ with exn -> e1 := None; raise exn ++ end ++ | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 -> ++ set_row_field e2 f1; ++ begin try ++ List.iter (unify env t1) tl; ++ List.iter (fun (t1,t2) -> unify env t1 t2) tp ++ with exn -> e2 := None; raise exn ++ end ++ | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 -> ++ set_row_field e1 f2; ++ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl + with exn -> e1 := None; raise exn) +- | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> ++ | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 -> + set_row_field e2 f1; +- (try List.iter (unify env t1) tl ++ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl + with exn -> e2 := None; raise exn) +- | Reither(true, [], _, e1), Rpresent None when not fixed1 -> +- set_row_field e1 f2 +- | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> +- set_row_field e2 f1 + | _ -> raise (Unify []) + + +@@ -1920,6 +1970,166 @@ + (* Matching between type schemes *) + (***********************************) + ++(* Forward declaration (order should be reversed...) *) ++let equal' = ref (fun _ -> failwith "Ctype.equal'") ++ ++let make_generics_univars tyl = ++ let polyvars = ref TypeSet.empty in ++ let rec make_rec ty = ++ let ty = repr ty in ++ if ty.level = generic_level then begin ++ if ty.desc = Tvar then begin ++ log_type ty; ++ ty.desc <- Tunivar; ++ polyvars := TypeSet.add ty !polyvars ++ end ++ else if ty.desc = Tunivar then set_level ty (generic_level - 1); ++ ty.level <- pivot_level - generic_level; ++ iter_type_expr make_rec ty ++ end ++ in ++ List.iter make_rec tyl; ++ List.iter unmark_type tyl; ++ !polyvars ++ ++(* New version of moregeneral, using unification *) ++ ++let copy_cond (p,tpl,l,row) = ++ let row = ++ match repr (copy (newgenty (Tvariant row))) with ++ {desc=Tvariant row} -> row ++ | _ -> assert false ++ and pairs = ++ List.map (fun (t1,t2) -> copy t1, copy t2) tpl in ++ (p, pairs, l, row) ++ ++let get_row_field l row = ++ try row_field_repr (List.assoc l (row_repr row).row_fields) ++ with Not_found -> Rabsent ++ ++let rec check_conditional_list env cdtls pattvars tpls = ++ match cdtls with ++ [] -> ++ let finished = ++ List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in ++ if not finished then begin ++ let polyvars = make_generics_univars pattvars in ++ delayed_conditionals := []; ++ allowed_univars := polyvars; ++ List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs) ++ tpls; ++ check_conditionals env polyvars !delayed_conditionals ++ end ++ | (pairs, tpl1, l, row2 as cond) :: cdtls -> ++ let cont = check_conditional_list env cdtls pattvars in ++ let tpl1 = ++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in ++ let included = ++ List.for_all ++ (fun (t1,t2) -> ++ List.exists ++ (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2']) ++ tpls) ++ tpl1 in ++ if included then cont tpls else ++ match get_row_field l row2 with ++ Rpresent _ -> ++ cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls) ++ | Rabsent -> cont tpls ++ | Reither (c, tl2, _, _, _) -> ++ cont tpls; ++ if c && tl2 <> [] then () (* cannot succeed *) else ++ let (pairs, tpl1, l, row2) = copy_cond cond ++ and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls ++ and pattvars = List.map copy pattvars ++ and cdtls = List.map copy_cond cdtls in ++ cleanup_types (); ++ let tl2, tpl2, e2 = ++ match get_row_field l row2 with ++ Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2 ++ | _ -> assert false ++ in ++ let snap = Btype.snapshot () in ++ let ok = ++ try ++ begin match tl2 with ++ [] -> ++ set_row_field e2 (Rpresent None) ++ | t::tl -> ++ set_row_field e2 (Rpresent (Some t)); ++ List.iter (unify env t) tl ++ end; ++ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2; ++ true ++ with exn -> ++ Btype.backtrack snap; ++ false ++ in ++ (* This is not [cont] : types have been copied *) ++ if ok then ++ check_conditional_list env cdtls pattvars ++ (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls) ++ ++and check_conditionals env polyvars cdtls = ++ let cdtls = List.map copy_cond cdtls in ++ let pattvars = ref [] in ++ TypeSet.iter ++ (fun ty -> ++ let ty = repr ty in ++ match ty.desc with ++ Tsubst ty -> ++ let ty = repr ty in ++ begin match ty.desc with ++ Tunivar -> ++ log_type ty; ++ ty.desc <- Tvar; ++ pattvars := ty :: !pattvars ++ | Ttuple [tv;_] -> ++ if tv.desc = Tunivar then ++ (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars) ++ else if tv.desc <> Tvar then assert false ++ | Tvar -> () ++ | _ -> assert false ++ end ++ | _ -> ()) ++ polyvars; ++ cleanup_types (); ++ check_conditional_list env cdtls !pattvars [] ++ ++ ++(* Must empty univar_pairs first *) ++let unify_poly env polyvars subj patt = ++ let old_level = !current_level in ++ current_level := generic_level; ++ delayed_conditionals := []; ++ allowed_univars := polyvars; ++ try ++ unify env subj patt; ++ check_conditionals env polyvars !delayed_conditionals; ++ current_level := old_level; ++ allowed_univars := TypeSet.empty; ++ delayed_conditionals := [] ++ with exn -> ++ current_level := old_level; ++ allowed_univars := TypeSet.empty; ++ delayed_conditionals := []; ++ raise exn ++ ++let moregeneral env _ subj patt = ++ let old_level = !current_level in ++ current_level := generic_level; ++ let subj = instance subj ++ and patt = instance patt in ++ let polyvars = make_generics_univars [patt] in ++ current_level := old_level; ++ let snap = Btype.snapshot () in ++ try ++ unify_poly env polyvars subj patt; ++ true ++ with Unify _ -> ++ Btype.backtrack snap; ++ false ++ + (* + Update the level of [ty]. First check that the levels of generic + variables from the subject are not lowered. +@@ -2072,35 +2282,101 @@ + Rpresent(Some t1), Rpresent(Some t2) -> + moregen inst_nongen type_pairs env t1 t2 + | Rpresent None, Rpresent None -> () +- | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ -> ++ | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ -> + set_row_field e1 f2; + List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 +- | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> ++ | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) -> + if e1 != e2 then begin + if c1 && not c2 then raise(Unify []); +- set_row_field e1 (Reither (c2, [], m2, e2)); +- if List.length tl1 = List.length tl2 then +- List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 +- else match tl2 with +- t2 :: _ -> ++ let tpl' = if tpl1 = [] then tpl2 else [] in ++ set_row_field e1 (Reither (c2, [], m2, tpl', e2)); ++ begin match tl2 with ++ [t2] -> + List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 +- | [] -> +- if tl1 <> [] then raise (Unify []) ++ | _ -> ++ if List.length tl1 <> List.length tl2 then raise (Unify []); ++ List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 ++ end; ++ if tpl1 <> [] then ++ delayed_conditionals := ++ (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals + end +- | Reither(true, [], _, e1), Rpresent None when not univ -> ++ | Reither(true, [], _, [], e1), Rpresent None when not univ -> + set_row_field e1 f2 +- | Reither(_, _, _, e1), Rabsent when not univ -> ++ | Reither(_, _, _, [], e1), Rabsent when not univ -> + set_row_field e1 f2 + | Rabsent, Rabsent -> () + | _ -> raise (Unify [])) + pairs + ++let check_conditional env (pairs, tpl1, l, row2) tpls cont = ++ let tpl1 = ++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in ++ let included = ++ List.for_all ++ (fun (t1,t2) -> ++ List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2']) ++ tpls) ++ tpl1 in ++ if tpl1 = [] || included then cont tpls else ++ match get_row_field l row2 with ++ Rpresent _ -> cont (tpl1 @ tpls) ++ | Rabsent -> cont tpls ++ | Reither (c, tl2, _, tpl2, e2) -> ++ if not c || tl2 = [] then begin ++ let snap = Btype.snapshot () in ++ let ok = ++ try ++ begin match tl2 with ++ [] -> ++ set_row_field e2 (Rpresent None) ++ | t::tl -> ++ set_row_field e2 (Rpresent (Some t)); ++ List.iter (unify env t) tl ++ end; ++ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2; ++ true ++ with Unify _ -> false ++ in ++ if ok then cont (tpl1 @ tpls); ++ Btype.backtrack snap ++ end; ++ cont tpls ++ ++let rec check_conditionals inst_nongen env cdtls tpls = ++ match cdtls with ++ [] -> ++ let tpls = ++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in ++ if tpls = [] then () else begin ++ delayed_conditionals := []; ++ let tl1, tl2 = List.split tpls in ++ let type_pairs = TypePairs.create 13 in ++ List.iter2 (moregen false type_pairs env) tl2 tl1; ++ check_conditionals inst_nongen env !delayed_conditionals [] ++ end ++ | cdtl :: cdtls -> ++ check_conditional env cdtl tpls ++ (check_conditionals inst_nongen env cdtls) ++ ++ + (* Must empty univar_pairs first *) + let moregen inst_nongen type_pairs env patt subj = + univar_pairs := []; +- moregen inst_nongen type_pairs env patt subj ++ delayed_conditionals := []; ++ try ++ moregen inst_nongen type_pairs env patt subj; ++ check_conditionals inst_nongen env !delayed_conditionals []; ++ univar_pairs := []; ++ delayed_conditionals := [] ++ with exn -> ++ univar_pairs := []; ++ delayed_conditionals := []; ++ raise exn ++ + ++(* old implementation + (* + Non-generic variable can be instanciated only if [inst_nongen] is + true. So, [inst_nongen] should be set to false if the subject might +@@ -2128,6 +2404,7 @@ + in + current_level := old_level; + res ++*) + + + (* Alternative approach: "rigidify" a type scheme, +@@ -2296,30 +2573,36 @@ + {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> raise Cannot_expand + with Cannot_expand -> ++ let eqtype_rec = eqtype rename type_pairs subst env in + 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 + if row1.row_closed <> row2.row_closed + || not row1.row_closed && (r1 <> [] || r2 <> []) + || filter_row_fields false (r1 @ r2) <> [] + then raise (Unify []); +- if not (static_row row1) then +- eqtype rename type_pairs subst env row1.row_more row2.row_more; ++ if not (static_row row1) then eqtype_rec row1.row_more row2.row_more; + List.iter + (fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> +- eqtype rename type_pairs subst env t1 t2 +- | Reither(true, [], _, _), Reither(true, [], _, _) -> +- () +- | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) -> +- eqtype rename type_pairs subst env t1 t2; ++ eqtype_rec t1 t2 ++ | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) -> ++ List.iter2 ++ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2') ++ tp1 tp2 ++ | Reither(false, t1::tl1, _, tpl1, _), ++ Reither(false, t2::tl2, _, tpl2, _) -> ++ eqtype_rec t1 t2; ++ List.iter2 ++ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2') ++ tpl1 tpl2; + if List.length tl1 = List.length tl2 then + (* if same length allow different types (meaning?) *) +- List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 ++ List.iter2 eqtype_rec tl1 tl2 + else begin + (* otherwise everything must be equal *) +- List.iter (eqtype rename type_pairs subst env t1) tl2; +- List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 ++ List.iter (eqtype_rec t1) tl2; ++ List.iter (fun t1 -> eqtype_rec t1 t2) tl1 + end + | Rpresent None, Rpresent None -> () + | Rabsent, Rabsent -> () +@@ -2334,6 +2617,8 @@ + with + Unify _ -> false + ++let () = equal' := equal ++ + (* Must empty univar_pairs first *) + let eqtype rename type_pairs subst env t1 t2 = + univar_pairs := []; +@@ -2770,14 +3055,14 @@ + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then +- (l, Reither(true, [], false, ref None)), Unchanged ++ (l, Reither(true, [], false, [], ref None)), Unchanged + else + orig, Unchanged + | Rpresent(Some t) -> + let (t', c) = build_subtype env visited loops posi level' t in + if posi && level > 0 then begin + bound := t' :: !bound; +- (l, Reither(false, [t'], false, ref None)), c ++ (l, Reither(false, [t'], false, [], ref None)), c + end else + (l, Rpresent(Some t')), c + | _ -> assert false) +@@ -2960,11 +3245,11 @@ + List.fold_left + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with +- (Rpresent None|Reither(true,_,_,_)), Rpresent None -> ++ (Rpresent None|Reither(true,_,_,[],_)), Rpresent None -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) -> + subtype_rec env ((t1, t2)::trace) t1 t2 cstrs +- | Reither(false, t1::_, _, _), Rpresent(Some t2) -> ++ | Reither(false, t1::_, _, [], _), Rpresent(Some t2) -> + subtype_rec env ((t1, t2)::trace) t1 t2 cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) +@@ -2977,11 +3262,11 @@ + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None +- | Reither(true,[],_,_), Reither(true,[],_,_) ++ | Reither(true,[],_,[],_), Reither(true,[],_,[],_) + | Rabsent, Rabsent -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) +- | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> ++ | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) -> + subtype_rec env ((t1, t2)::trace) t1 t2 cstrs + | _ -> raise Exit) + cstrs pairs +@@ -3079,16 +3364,26 @@ + let fields = List.map + (fun (l,f) -> + let f = row_field_repr f in l, +- match f with Reither(b, ty::(_::_ as tyl), m, e) -> +- let tyl' = +- List.fold_left +- (fun tyl ty -> +- if List.exists (fun ty' -> equal env false [ty] [ty']) tyl +- then tyl else ty::tyl) +- [ty] tyl ++ match f with Reither(b, tyl, m, tp, e) -> ++ let rem_dbl eq l = ++ List.rev ++ (List.fold_left ++ (fun xs x -> if List.exists (eq x) xs then xs else x::xs) ++ [] l) ++ in ++ let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl ++ and tp' = ++ List.filter ++ (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp ++ in ++ let tp' = ++ rem_dbl ++ (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2']) ++ tp' + in +- if List.length tyl' <= List.length tyl then +- let f = Reither(b, List.rev tyl', m, ref None) in ++ if List.length tyl' < List.length tyl ++ || List.length tp' < List.length tp then ++ let f = Reither(b, tyl', m, tp', ref None) in + set_row_field e f; + f + else f +@@ -3344,9 +3639,9 @@ + List.iter + (fun (l,fi) -> + match row_field_repr fi with +- Reither (c, t1::(_::_ as tl), m, e) -> ++ Reither (c, t1::(_::_ as tl), m, tp, e) -> + List.iter (unify env t1) tl; +- set_row_field e (Reither (c, [t1], m, ref None)) ++ set_row_field e (Reither (c, [t1], m, tp, ref None)) + | _ -> + ()) + row.row_fields; +Index: typing/includecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v +retrieving revision 1.32 +diff -u -r1.32 includecore.ml +--- typing/includecore.ml 8 Aug 2005 05:40:52 -0000 1.32 ++++ typing/includecore.ml 2 Feb 2006 06:28:32 -0000 +@@ -71,10 +71,10 @@ + (fun (_, f1, f2) -> + match Btype.row_field_repr f1, Btype.row_field_repr f2 with + Rpresent(Some t1), +- (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> ++ (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) -> + to_equal := (t1,t2) :: !to_equal; true +- | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true +- | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) ++ | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true ++ | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_) + when List.length tl1 = List.length tl2 && c1 = c2 -> + to_equal := List.combine tl1 tl2 @ !to_equal; true + | Rabsent, (Reither _ | Rabsent) -> true +Index: typing/oprint.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v +retrieving revision 1.22 +diff -u -r1.22 oprint.ml +--- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 ++++ typing/oprint.ml 2 Feb 2006 06:28:33 -0000 +@@ -223,14 +223,18 @@ + print_fields rest ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l +-and print_row_field ppf (l, opt_amp, tyl) = ++and print_row_field ppf (l, opt_amp, tyl, tpl) = + let pr_of ppf = + if opt_amp then fprintf ppf " of@ &@ " + else if tyl <> [] then fprintf ppf " of@ " +- else fprintf ppf "" +- in +- fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") +- tyl ++ and pr_tp ppf (t1,t2) = ++ fprintf ppf "@[%a =@ %a@]" ++ print_out_type t1 ++ print_out_type t2 ++ in ++ fprintf ppf "@[`%s%t%a%a@]" l pr_of ++ (print_typlist print_out_type " &") tyl ++ (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl + and print_typlist print_elem sep ppf = + function + [] -> () +Index: typing/outcometree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v +retrieving revision 1.14 +diff -u -r1.14 outcometree.mli +--- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 ++++ typing/outcometree.mli 2 Feb 2006 06:28:33 -0000 +@@ -61,7 +61,8 @@ + bool * out_variant * bool * (string list) option + | Otyp_poly of string list * out_type + and out_variant = +- | Ovar_fields of (string * bool * out_type list) list ++ | Ovar_fields of ++ (string * bool * out_type list * (out_type * out_type) list ) list + | Ovar_name of out_ident * out_type list + + type out_class_type = +Index: typing/parmatch.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v +retrieving revision 1.70 +diff -u -r1.70 parmatch.ml +--- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000 1.70 ++++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000 +@@ -568,11 +568,11 @@ + List.fold_left + (fun nm (tag,f) -> + match Btype.row_field_repr f with +- | Reither(_, _, false, e) -> ++ | Reither(_, _, false, _, e) -> + (* m=false means that this tag is not explicitly matched *) + Btype.set_row_field e Rabsent; + None +- | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) ++ | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm) + row.row_name row.row_fields in + if not row.row_closed || nm != row.row_name then begin + (* this unification cannot fail *) +@@ -605,8 +605,8 @@ + List.for_all + (fun (tag,f) -> + match Btype.row_field_repr f with +- Rabsent | Reither(_, _, false, _) -> true +- | Reither (_, _, true, _) ++ Rabsent | Reither(_, _, false, _, _) -> true ++ | Reither (_, _, true, _, _) + (* m=true, do not discard matched tags, rather warn *) + | Rpresent _ -> List.mem tag fields) + row.row_fields +@@ -739,7 +739,7 @@ + match Btype.row_field_repr f with + Rabsent (* | Reither _ *) -> others + (* This one is called after erasing pattern info *) +- | Reither (c, _, _, _) -> make_other_pat tag c :: others ++ | Reither (c, _, _, _, _) -> make_other_pat tag c :: others + | Rpresent arg -> make_other_pat tag (arg = None) :: others) + [] row.row_fields + with +Index: typing/printtyp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v +retrieving revision 1.140 +diff -u -r1.140 printtyp.ml +--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140 ++++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000 +@@ -157,9 +157,12 @@ + and raw_field ppf = function + Rpresent None -> fprintf ppf "Rpresent None" + | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t +- | Reither (c,tl,m,e) -> +- fprintf ppf "@[Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c +- raw_type_list tl m ++ | Reither (c,tl,m,tpl,e) -> ++ fprintf ppf "@[Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]" ++ c raw_type_list tl m ++ (raw_list ++ (fun ppf (t1,t2) -> ++ fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl + (fun ppf -> + match !e with None -> fprintf ppf " None" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) +@@ -219,8 +222,9 @@ + List.for_all + (fun (_, f) -> + match row_field_repr f with +- | Reither(c, l, _, _) -> +- row.row_closed && if c then l = [] else List.length l = 1 ++ | Reither(c, l, _, pl, _) -> ++ row.row_closed && pl = [] && ++ if c then l = [] else List.length l = 1 + | _ -> true) + row.row_fields + +@@ -392,13 +396,16 @@ + + and tree_of_row_field sch (l, f) = + match row_field_repr f with +- | Rpresent None | Reither(true, [], _, _) -> (l, false, []) +- | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) +- | Reither(c, tyl, _, _) -> +- if c (* contradiction: un constructeur constant qui a un argument *) +- then (l, true, tree_of_typlist sch tyl) +- else (l, false, tree_of_typlist sch tyl) +- | Rabsent -> (l, false, [] (* une erreur, en fait *)) ++ | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], []) ++ | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], []) ++ | Reither(c, tyl, _, tpl, _) -> ++ let ttpl = ++ List.map ++ (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2) ++ tpl ++ in ++ (l, c && tpl = [], tree_of_typlist sch tyl, ttpl) ++ | Rabsent -> (l, false, [], [] (* une erreur, en fait *)) + + and tree_of_typlist sch tyl = + List.map (tree_of_typexp sch) tyl +Index: typing/typeclass.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v +retrieving revision 1.85 +diff -u -r1.85 typeclass.ml +--- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85 ++++ typing/typeclass.ml 2 Feb 2006 06:28:33 -0000 +@@ -727,7 +727,7 @@ + {pexp_loc = loc; pexp_desc = + Pexp_match({pexp_loc = loc; pexp_desc = + Pexp_ident(Longident.Lident"*opt*")}, +- scases)} in ++ scases, false)} in + let sfun = + {pcl_loc = scl.pcl_loc; pcl_desc = + Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, +Index: typing/typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.178 +diff -u -r1.178 typecore.ml +--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178 ++++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000 +@@ -156,15 +156,21 @@ + let field = row_field tag row in + begin match field with + | 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 -> ++ | Reither (true, [], _, tpl, e) when not row.row_closed -> ++ set_row_field e (Rpresent None); ++ List.iter ++ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2) ++ tpl ++ | Reither (false, ty::tl, _, tpl, e) when not row.row_closed -> + set_row_field e (Rpresent (Some ty)); ++ List.iter ++ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2) ++ tpl; + begin match opat with None -> assert false + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) + end +- | Reither (c, l, true, e) when not row.row_fixed -> +- set_row_field e (Reither (c, [], false, ref None)) ++ | Reither (c, l, true, tpl, e) when not row.row_fixed -> ++ set_row_field e (Reither (c, [], false, [], ref None)) + | _ -> () + end; + (* Force check of well-formedness *) +@@ -307,13 +313,13 @@ + match row_field_repr f with + Rpresent None -> + (l,None) :: pats, +- (l, Reither(true,[], true, ref None)) :: fields ++ (l, Reither(true,[], true, [], ref None)) :: fields + | Rpresent (Some ty) -> + bound := ty :: !bound; + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty}) + :: pats, +- (l, Reither(false, [ty], true, ref None)) :: fields ++ (l, Reither(false, [ty], true, [], ref None)) :: fields + | _ -> pats, fields) + ([],[]) fields in + let row = +@@ -337,6 +343,18 @@ + pat pats in + rp { r with pat_loc = loc } + ++let rec flatten_or_pat pat = ++ match pat.pat_desc with ++ Tpat_or (p1, p2, _) -> ++ flatten_or_pat p1 @ flatten_or_pat p2 ++ | _ -> ++ [pat] ++ ++let all_variants pat = ++ List.for_all ++ (function {pat_desc=Tpat_variant _} -> true | _ -> false) ++ (flatten_or_pat pat) ++ + let rec find_record_qual = function + | [] -> None + | (Longident.Ldot (modname, _), _) :: _ -> Some modname +@@ -423,7 +441,7 @@ + let arg = may_map (type_pat env) sarg in + let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in + let row = { row_fields = +- [l, Reither(arg = None, arg_type, true, ref None)]; ++ [l, Reither(arg = None, arg_type, true, [], ref None)]; + row_bound = arg_type; + row_closed = false; + row_more = newvar (); +@@ -788,7 +806,7 @@ + newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)) + | Pexp_function (p,_,(_,e)::_) -> + newty (Tarrow(p, newvar (), type_approx env e, Cok)) +- | Pexp_match (_, (_,e)::_) -> type_approx env e ++ | Pexp_match (_, (_,e)::_, false) -> type_approx env e + | Pexp_try (e, _) -> type_approx env e + | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) + | Pexp_ifthenelse (_,e,_) -> type_approx env e +@@ -939,17 +957,26 @@ + exp_loc = sexp.pexp_loc; + exp_type = ty_res; + exp_env = env } +- | Pexp_match(sarg, caselist) -> ++ | Pexp_match(sarg, caselist, multi) -> + let arg = type_exp env sarg in + let ty_res = newvar() in + let cases, partial = +- type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ++ type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi + in + re { + exp_desc = Texp_match(arg, cases, partial); + exp_loc = sexp.pexp_loc; + exp_type = ty_res; + exp_env = env } ++ | Pexp_multifun caselist -> ++ let ty_arg = newvar() and ty_res = newvar() in ++ let cases, partial = ++ type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true ++ in ++ { exp_desc = Texp_function (cases, partial); ++ exp_loc = sexp.pexp_loc; ++ exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok)); ++ exp_env = env } + | Pexp_try(sbody, caselist) -> + let body = type_exp env sbody in + let cases, _ = +@@ -1758,7 +1785,7 @@ + {pexp_loc = loc; pexp_desc = + Pexp_match({pexp_loc = loc; pexp_desc = + Pexp_ident(Longident.Lident"*opt*")}, +- scases)} in ++ scases, false)} in + let sfun = + {pexp_loc = sexp.pexp_loc; pexp_desc = + Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, +@@ -1864,7 +1891,8 @@ + + (* Typing of match cases *) + +-and type_cases ?in_function env ty_arg ty_res partial_loc caselist = ++and type_cases ?in_function ?(multi=false) ++ env ty_arg ty_res partial_loc caselist = + let ty_arg' = newvar () in + let pattern_force = ref [] in + let pat_env_list = +@@ -1898,10 +1926,64 @@ + let cases = + List.map2 + (fun (pat, ext_env) (spat, sexp) -> +- let exp = type_expect ?in_function ext_env sexp ty_res in +- (pat, exp)) +- pat_env_list caselist +- in ++ let add_variant_case lab row ty_res ty_res' = ++ let fi = List.assoc lab (row_repr row).row_fields in ++ begin match row_field_repr fi with ++ Reither (c, _, m, _, e) -> ++ let row' = ++ { row_fields = ++ [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)]; ++ row_more = newvar (); row_bound = [ty_res; ty_res']; ++ row_closed = false; row_fixed = false; row_name = None } ++ in ++ unify_pat ext_env {pat with pat_type= newty (Tvariant row)} ++ (newty (Tvariant row')) ++ | _ -> ++ unify_exp ext_env ++ { exp_desc = Texp_tuple []; exp_type = ty_res; ++ exp_env = ext_env; exp_loc = sexp.pexp_loc } ++ ty_res' ++ end ++ in ++ pat, ++ match pat.pat_desc with ++ _ when multi && all_variants pat -> ++ let ty_res' = newvar () in ++ List.iter ++ (function {pat_desc=Tpat_variant(lab,_,row)} -> ++ add_variant_case lab row ty_res ty_res' ++ | _ -> assert false) ++ (flatten_or_pat pat); ++ type_expect ?in_function ext_env sexp ty_res' ++ | Tpat_alias (p, id) when multi && all_variants p -> ++ let vd = Env.find_value (Path.Pident id) ext_env in ++ let row' = ++ match repr vd.val_type with ++ {desc=Tvariant row'} -> row' ++ | _ -> assert false ++ in ++ begin_def (); ++ let tv = newvar () in ++ let env = Env.add_value id {vd with val_type=tv} ext_env in ++ let exp = type_exp env sexp in ++ end_def (); ++ generalize exp.exp_type; ++ generalize tv; ++ List.iter ++ (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] -> ++ let fi' = List.assoc lab (row_repr row').row_fields in ++ let row' = ++ {row' with row_fields=[lab,fi']; row_more=newvar()} in ++ unify_pat ext_env {pat with pat_type=tv'} ++ (newty (Tvariant row')); ++ add_variant_case lab row ty_res ty' ++ | _ -> assert false) ++ (List.map (fun p -> p, instance_list [tv; exp.exp_type]) ++ (flatten_or_pat p)); ++ {exp with exp_type = instance exp.exp_type} ++ | _ -> ++ type_expect ?in_function ext_env sexp ty_res) ++ pat_env_list caselist in + let partial = + match partial_loc with None -> Partial + | Some loc -> Parmatch.check_partial loc cases +Index: typing/typedecl.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v +retrieving revision 1.75 +diff -u -r1.75 typedecl.ml +--- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000 1.75 ++++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000 +@@ -432,8 +432,10 @@ + match Btype.row_field_repr f with + Rpresent (Some ty) -> + compute_same ty +- | Reither (_, tyl, _, _) -> +- List.iter compute_same tyl ++ | Reither (_, tyl, _, tpl, _) -> ++ List.iter compute_same tyl; ++ List.iter (compute_variance_rec true true true) ++ (List.map fst tpl @ List.map snd tpl) + | _ -> ()) + row.row_fields; + compute_same row.row_more +@@ -856,8 +858,8 @@ + explain row.row_fields + (fun (l,f) -> match Btype.row_field_repr f with + Rpresent (Some t) -> t +- | Reither (_,[t],_,_) -> t +- | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) ++ | Reither (_,[t],_,_,_) -> t ++ | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple[])) + "case" (fun (lab,_) -> "`" ^ lab ^ " of ") + | _ -> trivial ty' +Index: typing/types.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v +retrieving revision 1.25 +diff -u -r1.25 types.ml +--- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25 ++++ typing/types.ml 2 Feb 2006 06:28:33 -0000 +@@ -48,7 +48,9 @@ + + and row_field = + Rpresent of type_expr option +- | Reither of bool * type_expr list * bool * row_field option ref ++ | Reither of ++ bool * type_expr list * bool * ++ (type_expr * type_expr) list * row_field option ref + | Rabsent + + and abbrev_memo = +Index: typing/types.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v +retrieving revision 1.25 +diff -u -r1.25 types.mli +--- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25 ++++ typing/types.mli 2 Feb 2006 06:28:33 -0000 +@@ -47,7 +47,9 @@ + + and row_field = + Rpresent of type_expr option +- | Reither of bool * type_expr list * bool * row_field option ref ++ | Reither of ++ bool * type_expr list * bool * ++ (type_expr * type_expr) list * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) +Index: typing/typetexp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v +retrieving revision 1.54 +diff -u -r1.54 typetexp.ml +--- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54 ++++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000 +@@ -207,9 +207,9 @@ + match Btype.row_field_repr f with + | Rpresent (Some ty) -> + bound := ty :: !bound; +- Reither(false, [ty], false, ref None) ++ Reither(false, [ty], false, [], ref None) + | Rpresent None -> +- Reither (true, [], false, ref None) ++ Reither (true, [], false, [], ref None) + | _ -> f) + row.row_fields + in +@@ -273,13 +273,16 @@ + (l, f) :: fields + in + let rec add_field fields = function +- Rtag (l, c, stl) -> ++ Rtag (l, c, stl, stpl) -> + name := None; + let f = match present with + Some present when not (List.mem l present) -> +- let tl = List.map (transl_type env policy) stl in +- bound := tl @ !bound; +- Reither(c, tl, false, ref None) ++ let transl_list = List.map (transl_type env policy) in ++ let tl = transl_list stl in ++ let stpl1, stpl2 = List.split stpl in ++ let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in ++ bound := tl @ tpl1 @ tpl2 @ !bound; ++ Reither(c, tl, false, List.combine tpl1 tpl2, ref None) + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, Present_has_conjunction l)); +@@ -311,9 +314,9 @@ + begin match f with + Rpresent(Some ty) -> + bound := ty :: !bound; +- Reither(false, [ty], false, ref None) ++ Reither(false, [ty], false, [], ref None) + | Rpresent None -> +- Reither(true, [], false, ref None) ++ Reither(true, [], false, [], ref None) + | _ -> + assert false + end +@@ -406,7 +409,8 @@ + {row with row_fixed=true; + row_fields = List.map + (fun (s,f as p) -> match Btype.row_field_repr f with +- Reither (c, tl, m, r) -> s, Reither (c, tl, true, r) ++ Reither (c, tl, m, tpl, r) -> ++ s, Reither (c, tl, true, tpl, r) + | _ -> p) + row.row_fields}; + Btype.iter_row make_fixed_univars row +Index: typing/unused_var.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v +retrieving revision 1.5 +diff -u -r1.5 unused_var.ml +--- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5 ++++ typing/unused_var.ml 2 Feb 2006 06:28:33 -0000 +@@ -122,9 +122,11 @@ + | Pexp_apply (e, lel) -> + expression ppf tbl e; + List.iter (fun (_, e) -> expression ppf tbl e) lel; +- | Pexp_match (e, pel) -> ++ | Pexp_match (e, pel, _) -> + expression ppf tbl e; + match_pel ppf tbl pel; ++ | Pexp_multifun pel -> ++ match_pel ppf tbl pel; + | Pexp_try (e, pel) -> + expression ppf tbl e; + match_pel ppf tbl pel; +Index: bytecomp/matching.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v +retrieving revision 1.67 +diff -u -r1.67 matching.ml +--- bytecomp/matching.ml 7 Sep 2005 16:07:48 -0000 1.67 ++++ bytecomp/matching.ml 2 Feb 2006 06:28:33 -0000 +@@ -1991,7 +1991,7 @@ + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with +- Rabsent | Reither(true, _::_, _, _) -> () ++ Rabsent | Reither(true, _::_, _, _, _) -> () + | _ -> incr num_constr) + row.row_fields + else +Index: toplevel/genprintval.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v +retrieving revision 1.38 +diff -u -r1.38 genprintval.ml +--- toplevel/genprintval.ml 13 Jun 2005 04:55:53 -0000 1.38 ++++ toplevel/genprintval.ml 2 Feb 2006 06:28:33 -0000 +@@ -293,7 +293,7 @@ + | (l, f) :: fields -> + if Btype.hash_variant l = tag then + match Btype.row_field_repr f with +- | Rpresent(Some ty) | Reither(_,[ty],_,_) -> ++ | Rpresent(Some ty) | Reither(_,[ty],_,_,_) -> + let args = + tree_of_val (depth - 1) (O.field obj 1) ty in + Oval_variant (l, Some args) diff --git a/experimental/garrigue/multimatch.ml b/experimental/garrigue/multimatch.ml new file mode 100644 index 00000000..7c9aa73f --- /dev/null +++ b/experimental/garrigue/multimatch.ml @@ -0,0 +1,158 @@ +(* Simple example *) +let f x = + (multimatch x with `A -> 1 | `B -> true), + (multimatch x with `A -> 1. | `B -> "1");; + +(* OK *) +module M : sig + val f : + [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b +end = struct let f = f end;; + +(* Bad *) +module M : sig + val f : + [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b +end = struct let f = f end;; + +(* Should be good! *) +module M : sig + val f : + [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a +end = struct let f = f end;; + +let f = multifun `A|`B as x -> f x;; + +(* Two-level example *) +let f = multifun + `A -> (multifun `C -> 1 | `D -> 1.) + | `B -> (multifun `C -> true | `D -> "1");; + +(* OK *) +module M : sig + val f : + [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a + | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b +end = struct let f = f end;; + +(* Bad *) +module M : sig + val f : + [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a + | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b +end = struct let f = f end;; + +module M : sig + val f : + [< `A & 'b = [< `C & 'a = int | `D] -> 'a + | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b +end = struct let f = f end;; + + +(* Examples with hidden sharing *) +let r = ref [] +let f = multifun `A -> 1 | `B -> true +let g x = r := [f x];; + +(* Bad! *) +module M : sig + val g : [< `A & 'a = int | `B & 'a = bool] -> unit +end = struct let g = g end;; + +let r = ref [] +let f = multifun `A -> r | `B -> ref [];; +(* Now OK *) +module M : sig + val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b +end = struct let f = f end;; +(* Still OK *) +let l : int list ref = r;; +module M : sig + val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b +end = struct let f = f end;; + + +(* Examples that would need unification *) +let f = multifun `A -> (1, []) | `B -> (true, []) +let g x = fst (f x);; +(* Didn't work, now Ok *) +module M : sig + val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a +end = struct let g = g end;; +let g = multifun (`A|`B) as x -> g x;; + +(* Other examples *) + +let f x = + let a = multimatch x with `A -> 1 | `B -> "1" in + (multifun `A -> print_int | `B -> print_string) x a +;; + +let f = multifun (`A|`B) as x -> f x;; + +type unit_op = [`Set of int | `Move of int] +type int_op = [`Get] + +let op r = + multifun + `Get -> !r + | `Set x -> r := x + | `Move dx -> r := !r + dx +;; + +let rec trace r = function + [] -> [] + | op1 :: ops -> + multimatch op1 with + #int_op as op1 -> + let x = op r op1 in + x :: trace r ops + | #unit_op as op1 -> + op r op1; + trace r ops +;; + +class point x = object + val mutable x : int = x + method get = x + method set y = x <- y + method move dx = x <- x + dx +end;; + +let poly sort coeffs x = + let add, mul, zero = + multimatch sort with + `Int -> (+), ( * ), 0 + | `Float -> (+.), ( *. ), 0. + in + let rec compute = function + [] -> zero + | c :: cs -> add c (mul x (compute cs)) + in + compute coeffs +;; + +module M : sig + val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a +end = struct let poly = poly end;; + +type ('a,'b) num_sort = + 'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float] +module M : sig + val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a +end = struct let poly = poly end;; + + +(* type dispatch *) + +type num = [ `Int | `Float ] +let print0 = multifun + `Int -> print_int + | `Float -> print_float +;; +let print1 = multifun + #num as x -> print0 x + | `List t -> List.iter (print0 t) + | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y) +;; +print1 (`Pair(`Int,`Float)) (1,1.0);; diff --git a/experimental/garrigue/newlabels.ps b/experimental/garrigue/newlabels.ps new file mode 100644 index 00000000..01eac194 --- /dev/null +++ b/experimental/garrigue/newlabels.ps @@ -0,0 +1,1458 @@ +%!PS-Adobe-2.0 +%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp) +%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com) +%%Title: newlabels.dvi +%%Pages: 2 0 +%%PageOrder: Ascend +%%BoundingBox: 0 0 596 842 +%%EndComments +%%BeginProcSet: PStoPS 1 15 +userdict begin +[/showpage/erasepage/copypage]{dup where{pop dup load + type/operatortype eq{1 array cvx dup 0 3 index cvx put + bind def}{pop}ifelse}{pop}ifelse}forall +[/letter/legal/executivepage/a4/a4small/b5/com10envelope + /monarchenvelope/c5envelope/dlenvelope/lettersmall/note + /folio/quarto/a5]{dup where{dup wcheck{exch{}put} + {pop{}def}ifelse}{pop}ifelse}forall +/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put} + {pop def}ifelse}{def}ifelse +/PStoPSmatrix matrix currentmatrix def +/PStoPSxform matrix def/PStoPSclip{clippath}def +/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def +/initmatrix{matrix defaultmatrix setmatrix}bind def +/initclip[{matrix currentmatrix PStoPSmatrix setmatrix + [{currentpoint}stopped{$error/newerror false put{newpath}} + {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse] + {[/newpath cvx{/moveto cvx}{/lineto cvx} + {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop} + stopped{$error/errorname get/invalidaccess eq{cleartomark + $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop + /initclip dup load dup type dup/operatortype eq{pop exch pop} + {dup/arraytype eq exch/packedarraytype eq or + {dup xcheck{exch pop aload pop}{pop cvx}ifelse} + {pop cvx}ifelse}ifelse + {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def +/initgraphics{initmatrix newpath initclip 1 setlinewidth + 0 setlinecap 0 setlinejoin []0 setdash 0 setgray + 10 setmiterlimit}bind def +end +%%EndProcSet +%DVIPSCommandLine: dvips -f newlabels +%DVIPSParameters: dpi=300 +%DVIPSSource: TeX output 1999.10.26:1616 +%%BeginProcSet: tex.pro +%! +/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N +/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72 +mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1} +ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale +isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div +hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul +TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if} +forall round exch round exch]setmatrix}N /@landscape{/isls true N}B +/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B +/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{ +/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N +string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N +end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{ +/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0] +N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup +length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{ +128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub +get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data +dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N +/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup +/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx +0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff +setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff +.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]} +if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup +length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{ +cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin +0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul +add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict +/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook +known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X +/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn +put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N +/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley +X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[ +(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup +length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse} +forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false +RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1 +false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform +round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg +rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail +{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M} +B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{ +4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{ +p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p +a}B /bos{/SS save N}B /eos{SS restore}B end + +%%EndProcSet +TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi) +@start +%DVIPSBitmapFont: Fa cmr6 6 2 +/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49 +D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F +8F0F> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fb cmmi8 8 4 +/Fb 4 111 df 85 D<0300038003000000000000000000000000001C00240046 +0046008C000C0018001800180031003100320032001C0009177F960C> 105 +D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06 +00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109 +D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818 +80300980300E00120E7F8D15> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fc cmbx8 8 4 +/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007 +800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C +3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D 109 D I +E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fd cmsy8 8 3 +/Fd 3 93 df 0 D<020002000200C218F2783AE00F800F80 +3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0 +0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0 +006040002013137E9218> 92 D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fe cmtt12 12 43 +/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF +F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF +F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35 +D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1 +FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C +08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38 +D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0 +00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003 +C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0 +01C000E000E0007000700070003800380038003800380038003800380038003800700070 +007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0 +FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0 +01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0 +7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070 +F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00 +003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D +9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001 +E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000 +38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F +FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007 +FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E +03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070 +03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F +FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F +C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A> +I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I< +0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000 +FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0 +0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000 +007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F +C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000 +FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38 +01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000 +E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070 +1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0 +E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070 +000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E +9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800 +003800003800003800003800003800003800003800003800003800003800003800003800 +00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I 91 D 93 D<1FF0003FFC007FFE00780F +00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003 +80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00 +000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00 +380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF +C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070 +0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003 +FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0 +0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0 +E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A> +I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF +F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00 +07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000 +E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000 +E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000 +0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0 +0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC +FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000 +0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000 +00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80 +121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108 +D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C +001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C +007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F +00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E +00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0 +7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80 +1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00 +380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF +C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0 +007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003 +80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F +FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F +C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3 +F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0 +FFFFE0038000038000038000038000038000038000038000038000038000038000038070 +03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07 +E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00 +E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E +00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000 +EE0000EE0000EE00007C00007C0000380017157F941A> I I<7FC7F87FCFFC7FC7F80703C00383 +8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783 +C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007 +00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000 +6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F +C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0 +F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D +E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Ff cmr8 8 3 +/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000 +003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000 +00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E +000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49 +D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810 +183FF07FF0FFF00D157E9412> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fg cmmi12 12 13 +/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0 +0000C00000C00000C00001C0000180000180000380000380000380000700000300001615 +7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000 +004000000040000000800000008000000080000000800000010000000FE00000711C0001 +C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0 +080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001 +FE0000002000000020000000400000004000000040000000400000008000000080000000 +800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58 +D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000 +0300000300000600000600000600000C00000C00000C0000180000180000180000300000 +300000300000600000600000600000C00000C00000C00001800001800001800001800003 +00000300000300000600000600000600000C00000C00000C000018000018000018000030 +0000300000300000600000600000600000C00000C00000C0000011317DA418> 61 +D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00 +00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000 +0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000 +8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76 +D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780 +04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00 +00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800 +000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84 +D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000 +07800020000F000040000F000040000F000040000F000040001E000080001E000080001E +000080001E000080003C000100003C000100003C000100003C0001000078000200007800 +020000780002000078000200007000040000F000040000F0000800007000080000700010 +00007000200000380040000038008000001C01000000060600000001F800000021237DA1 +21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000 +E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417> +101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E +001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C +000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0 +0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E +000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418 +> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00 +001C00001C00001C00001C000038000038000038000038000070000030000012157E9416 +> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038 +0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C +> 120 D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fh cmti12 12 22 +/Fh 22 122 df 45 D<70F8F8F0E005057A840F> I<00F8 +C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E +00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97 +D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C +0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010 +237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000 +780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B +9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000 +E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807 +00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07 +8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000 +E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186 +000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00 +000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000 +00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000 +F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380 +700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07 +80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0 +003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E +002300430043008700870087000E000E001C001C001C0038003800384070807080708071 +0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001 +C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E +20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070 +3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380 +038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000 +700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047 +6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00 +E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380 +70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E +40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038 +0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180 +0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780 +700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878 +0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380 +7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00 +001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087 +00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038 +000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C +00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040 +08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF +F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070 +8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030 +8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080 +1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119 +D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0 +0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E +00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C +03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060 +1C00F03800F03000E0600080C0004380003E0000141F7B9418> I +E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fi cmbx12 12 20 +/Fi 20 122 df 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006 +FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F +00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80 +18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003 +F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8 +00000003F800000003F800000003F800000003F800000003F800000003F800000003F800 +000003F800000003F800000003F800000003F800000003F800000003F800000003F80000 +0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022 +227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0 +03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F +18167E951B> 97 D I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000 +FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060 +07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00 +F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0 +7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1 +E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0 +0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0 +0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780 +1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000 +0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00 +3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00 +0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000 +00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F001F001F00FFE0FFE00B247EA310> 105 D 108 +D I I<00FE0007FFC00F83E01E00F03E00F87C00 +7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00 +F81F01F00F83E007FFC000FE0017167E951C> I I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F +E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF +FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007 +80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F +80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000 +F80011207F9F16> I I 120 D I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fj cmsy10 12 15 +/Fj 15 107 df 0 D<03F0000FFC001FFE003FFF007F +FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F +FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000 +060000000C0000001800000030000000300000006000000060000000C0000000C0000000 +C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000 +30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A +27> 26 D<00000001800000000001800000000001800000000001800000000000C00000 +000000C000000000006000000000003000000000003000000000001C00000000000E0000 +0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000 +000000300000000000300000000000600000000000C00000000000C00000000001800000 +00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003 +80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF +FFFFC00000C000006000006000006000003000003000001800000C000006000003800001 +E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00 +00180000180000300000300000600000600000C00000C00000C000018000018000030000 +0300000600000600000C00000C0000180000180000300000300000600000600000C00000 +C0000180000180000300000300000300000600000600000C00000C000018000018000030 +0000300000600000600000C00000400000183079A300> 54 D I<00008000018001F980070F000C0300180380180780 +3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070 +E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0 +7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E +A519> 59 D<000100000003000000030000000300000003000000030000000300000003 +000000030000000300000003000000030000000300000003000000030000000300000003 +000000030000000300000003000000030000000300000003000000030000000300000003 +000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63 +D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000 +C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000 +C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006 +000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780 +78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000 +00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000 +00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000 +00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300 +0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030 +00030030000300300006001800060018000C000C000C000C000C000C0018000600180006 +003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94 +D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00 +00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E +000003C012317DA419> 102 D I 106 D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fk cmr12 12 65 +/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007 +003800070038000700380007003800070038000700380007003800FFFFFFC00700380007 +003800070038000700380007003800070038000700380007003800070038000700380007 +0038000700380007003800070038000700380007003800070038000700380007003C007F +E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800 +0700300007000000070000000700000007000000070000000700000007000000FFFFF800 +070078000700380007003800070038000700380007003800070038000700380007003800 +070038000700380007003800070038000700380007003800070038000700380007003800 +070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007 +0038000700380007003800070038000700380007003800070038000700380007003800FF +FFF800070038000700380007003800070038000700380007003800070038000700380007 +003800070038000700380007003800070038000700380007003800070038000700380007 +003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E +00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00 +0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0 +07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007 +001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700 +1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006 +0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000 +7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 +6000600060007000300030003000180018000C000C000400060003000100008000400020 +0B327CA413> I<800040002000100018000C000400060006000300030001800180018001 +C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 +C000C000C001C0018001800180030003000600060004000C00180010002000400080000B +327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44 +D I<70F8F8F87005057C840E> I<01F000071C000C0600180300 +3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0 +F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0 +3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003 +800380038003800380038003800380038003800380038003800380038003800380038003 +800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007 +002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003 +C0000780000700000E00001C0000180000300000600000C0000180000100000200200400 +200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020 +07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003 +F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0 +03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700 +000700000F00001700001700002700006700004700008700018700010700020700060700 +040700080700080700100700200700200700400700C00700FFFFF8000700000700000700 +000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000 +000000000070F8F8F87005157C940E> 58 D 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0 +00800080018001000100010001000100010000000000000000000000038007C007C007C0 +038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000 +05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000 +203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001 +000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E +0001F8FF800FFF20237EA225> 65 D I<0007E0100038183000E0063001C00170038000F007 +0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8 +000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078 +0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001 +C0010000E0020000381C000007E0001C247DA223> I I 70 D<0007F008003C0C1800E0021801C0 +01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800 +000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800 +1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700 +0078038000B801C000B800E00318003C0C080007F00020247DA226> I I I 75 +D I +78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C +0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8 +00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C +0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000 +0FE0001F247DA226> I I 82 D<03F0200C0C601802603001E07000E0600060E00060E000 +60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F +C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000 +C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008 +4007800840078008C007800C800780048007800480078004800780040007800000078000 +000780000007800000078000000780000007800000078000000780000007800000078000 +000780000007800000078000000780000007800000078000000780000007800000078000 +00078000000FC00001FFFE001E227EA123> I 86 D I 91 D 93 +D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07 +00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97 +D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00 +1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723 +7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0 +0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94 +16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0 +F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE +17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000 +00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315 +7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007 +0000070000070000070000FFF80007000007000007000007000007000007000007000007 +00000700000700000700000700000700000700000700000700000700000700000780007F +F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780 +7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0 +0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00 +15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00 +700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00 +70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000 +000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E +000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000 +00000000007007F000F00070007000700070007000700070007000700070007000700070 +00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F> +I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8 +000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723 +7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E +000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E +00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E +003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00 +3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038 +00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E +00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E +0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078 +F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700 +01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00 +1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F +000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B +> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0 +00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000 +00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F +0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0 +10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80 +0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00 +1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04 +0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E +00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006 +017003827800FC7F18157F941B> I I I I I<3FFFC0380380300780200700600E +00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00 +80380080780180700780FFFF8012157F9416> I 124 +D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fl cmbx12 14.4 19 +/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000 +FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007 +7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF +00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80 +0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800 +003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8 +31> 67 D +76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000 +03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000 +007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000 +003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000 +003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000 +007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800 +07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C +A833> 79 D 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F +801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F +803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F +FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D I<00007FF000007FF000007FF0000007F0000007F0000007 +F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007 +F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007 +F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007 +F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87 +FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00 +0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00 +0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0 +1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07 +F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007 +F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007 +F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018 +2A7EA915> I +104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF +E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F +E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I 108 D 110 D<003FE00001FFFC0003F07E000FC01F801F80 +0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00 +03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80 +0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I I 114 D<03FE300FFFF03E03F078 +00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800 +FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016 +1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000 +0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000 +0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070 +07F0E003F0C001FF80007F0014267FA51A> I I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fm cmr12 14.4 20 +/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44 +D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0 +0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0 +0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0 +0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001 +F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000 +F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0 +000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628 +7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C +00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC +001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C +003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54 +D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800 +1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700 +9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00 +E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000 +1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80 +0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000 +0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000 +00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0 +3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000 +F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71 +D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03 +C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74 +D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780 +07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E +000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00 +00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000 +00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003 +C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000 +272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0 +000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0 +007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F +8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00 +00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00 +00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00 +01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00 +01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F +C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000 +F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008 +1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00 +E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800 +007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101 +D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0 +007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00 +0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C +0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E +0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00 +1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00 +0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0 +0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E +F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C +1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300 +0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00 +F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00 +1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00 +00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99 +1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F +00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F +00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080 +E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0 +8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080 +000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780 +000780000780000780000780000780000780000780000780000780000780000780000780 +0007804007804007804007804007804007804007804003C08001C08000E100003E001225 +7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F +000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F +000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F +F01C1A7E9921> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fn cmr17 20.74 18 +/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000 +03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8 +0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000 +000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000 +0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000 +0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000 +00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000 +FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F +0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0 +00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000 +00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000 +01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00 +0000313D7CBB39> 67 D 76 D<000003FF00000000001E01E000000000F0003C000000 +03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8 +0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000 +00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000 +0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000 +01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001 +FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC +FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F +0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80 +00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000 +00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000 +01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0 +0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E +00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0 +001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000 +01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E +0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00 +0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97 +D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000 +03E000000003E000000003E000000003E000000003E000000003E000000003E000000003 +E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0 +00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800 +03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000 +7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E +03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803 +E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383 +001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0 +03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000 +7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000 +FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018 +0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000 +3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E +00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC +000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F +0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F +257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0 +00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB +18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000 +0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007 +C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0 +000380000000000000000000000000000000000000000000000000000000000000000000 +0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF +C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E +01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00 +03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007 +C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 +03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007 +C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 +03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007 +C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 +07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000 +FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003 +F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0 +0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000 +07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007 +C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF +28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C +000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0 +7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC +000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00 +000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001 +C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003 +E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003 +E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003 +E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003 +E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114 +D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006 +00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0 +0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003 +80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070 +00807F800019257DA41F> I<003000000030000000300000003000000030000000300000 +0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000 +07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180 +01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400 +000E08000003F00019357FB41E> I 118 +D E +%EndDVIPSBitmapFont +end +%%EndProlog +%%BeginSetup +%%Feature: *Resolution 300dpi +TeXDict begin +%%PaperSize: a4 + +userdict/PStoPSxform PStoPSmatrix matrix currentmatrix + matrix invertmatrix matrix concatmatrix + matrix invertmatrix put +%%EndSetup +%%Page: (0,1) 1 +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 0.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +/showpage{}def/copypage{}def/erasepage{}def +PStoPSxform concat +1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p +927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404 +370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719 +634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p +Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p +319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929 +a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101 +929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p +Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073 +a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p +259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687 +1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p +1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360 +1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280 +a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459 +1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p +878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m +(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p +1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p +303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p +681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p +1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340 +a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p +1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p +322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk +133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502 +a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p +918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84 +1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p +492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p +891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p +Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838 +a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594 +1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p +991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301 +1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p +Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg +634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579 +2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004 +a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p +Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p +Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391 +2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p +656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh +634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p +Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p +Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p +Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245 +a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245 +a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj +579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305 +a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p +Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p +Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365 +a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p +Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p +Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365 +a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p +Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p +634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634 +2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182 +2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p +Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634 +2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p +Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p +Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh +956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop +PStoPSsaved restore +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 421.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +PStoPSxform concat +2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p +Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141 +261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495 +261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p +Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227 +366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p +Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366 +a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366 +a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p +Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p +Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p +Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427 +a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk +790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p +877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936 +434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010 +427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108 +427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185 +427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289 +427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427 +a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408 +427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p +Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487 +a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p +Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p +Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p +551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610 +494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671 +494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p +Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p +Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p +Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p +Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020 +547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p +Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p +Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p +Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p +Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547 +a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554 +a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p +Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p +Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607 +a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk +451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p +538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597 +614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p +Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614 +a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417 +607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588 +607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p +1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc +1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579 +667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p +Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p +Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p +945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk +1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728 +a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246 +728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p +Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p +Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p +555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk +629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk +698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p +Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735 +a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999 +728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061 +728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p +Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p +Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728 +a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735 +a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p +Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p +Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788 +a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788 +a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p +1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p +Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p +Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p +Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848 +a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk +470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p +557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616 +855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688 +855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772 +855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848 +a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000 +848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060 +855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p +Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p +Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p +Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848 +a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855 +a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p +Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908 +a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi +906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p +Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p +1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p +Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p +Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p +240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p +685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127 +a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127 +a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11 +1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187 +a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187 +a(original) p 764 1187 a(comfort) p 949 1187 a(of) p +1009 1187 a(out-of-order) p 1283 1187 a(application) p +1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814 +1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p +431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p +1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p +1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626 +1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p +Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308 +a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p +Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p +355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519 +1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p +884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210 +1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p +1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11 +1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605 +a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p +728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p +1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p +1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605 +a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p +184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p +440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620 +1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184 +1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440 +1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839 +a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p +363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568 +1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p +927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p +312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491 +1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p +902 1960 a(=) p 953 1960 a() 133 2020 y(val) p 235 +2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020 +a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020 +a(=) p 773 2020 a() 133 2080 y(val) p 235 2080 a(f3) p +312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491 +2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p +927 2080 a(=) p 978 2080 a() 133 2140 y(#) p 184 +2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140 +a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p +722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184 +2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200 +a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a() 133 +2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260 +a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p +645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321 +a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p +543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p +850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p +1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p +1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p +261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p +204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555 +a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555 +a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138 +2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462 +2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555 +a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p +Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615 +a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270 +2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p +547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p +850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p +1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515 +2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11 +2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p +310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p +718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p +Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p +1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p +1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p +153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p +477 2796 a(principal.) 926 2937 y(2) p eop +PStoPSsaved restore +%%Page: (2,3) 2 +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 0.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +/showpage{}def/copypage{}def/erasepage{}def +PStoPSxform concat +3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p +382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p +684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p +1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p +1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p +Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p +183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p +759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p +1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p +1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p +1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p +463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289 +a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p +1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p +1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p +1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p +181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p +581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p +Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571 +a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p +466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p +1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p +1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753 +571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p +199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p +472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631 +a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631 +a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p +1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p +1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p +1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p +403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p +694 692 a(from) p 809 692 a(constructors) p 1086 692 +a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692 +a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p +307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p +702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752 +a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204 +752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p +1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p +1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o +(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p +952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff +252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327 +939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939 +a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932 +a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585 +932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932 +a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p +797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932 +a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939 +a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p +Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127 +939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184 +944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p +Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939 +a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450 +939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525 +939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633 +939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042 +a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042 +a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o +(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042 +a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547 +1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p +1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p +214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162 +y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399 +1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p +145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p +460 1222 a(structural) p 685 1222 a(constrain) o(ts) p +934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p +1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222 +a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746 +1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p +Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p +418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p +Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p +967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282 +a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p +Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282 +a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p +365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p +833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p +1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515 +1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11 +1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p +417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p +646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015 +1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p +1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249 +1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p +Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p +Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p +753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p +Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509 +a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629 +a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629 +a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p +Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p +Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757 +1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629 +a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629 +a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p +372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p +Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p +Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p +Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p +Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689 +a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p +1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p +Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689 +a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689 +a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb +1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p +Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796 +a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796 +a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p +1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366 +1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p +1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p +211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p +Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856 +a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p +908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856 +a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469 +1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986 +a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p +188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p +458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078 +a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p +1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551 +2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11 +2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p +290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138 +a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244 +a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh +904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p +Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365 +a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p +Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120 +2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234 +2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496 +2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p +907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531 +a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531 +a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146 +2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p +466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926 +2937 y(3) p eop +PStoPSsaved restore +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 421.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +PStoPSxform concat +4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p +133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p +436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p +907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p +1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688 +261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p +266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p +909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p +1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p +1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772 +321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p +325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p +666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p +926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381 +a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p +1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p +1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441 +a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496 +441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p +881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501 +y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p +512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p +810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk +133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p +482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715 +616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p +1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p +1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133 +676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p +311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563 +676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p +979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p +272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579 +777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865 +777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p +1200 777 a(extension,) p 1426 777 a(simpli\014cation) p +1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p +310 838 a(|marking) p 551 838 a(constructors) p 830 838 +a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p +1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p +1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p +536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p +1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197 +898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898 +a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p +244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637 +958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p +1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958 +a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669 +958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p +469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772 +1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p +1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018 +a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018 +a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84 +1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516 +1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p +922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193 +a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515 +1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193 +a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p +363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253 +a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p +1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p +1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p +Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p +380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p +678 1490 a(other) p 812 1490 a(features:) p 1029 1490 +a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521 +1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11 +1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p +394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p +692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p +978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550 +a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550 +a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p +191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p +647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p +1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p +1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11 +1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p +283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p +603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y) +l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730 +a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p +845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p +1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730 +a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791 +y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p +482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791 +a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p +1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791 +a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926 +2937 y(4) p eop +PStoPSsaved restore +%%Trailer +end +userdict /end-hook known{end-hook}if +%%EOF diff --git a/experimental/garrigue/objvariant.diffs b/experimental/garrigue/objvariant.diffs new file mode 100644 index 00000000..75deb24c --- /dev/null +++ b/experimental/garrigue/objvariant.diffs @@ -0,0 +1,354 @@ +? objvariants-3.09.1.diffs +? objvariants.diffs +Index: btype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v +retrieving revision 1.37.4.1 +diff -u -r1.37.4.1 btype.ml +--- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1 ++++ btype.ml 16 Jan 2006 02:23:14 -0000 +@@ -177,7 +177,8 @@ + Tvariant row -> iter_row f row + | Tvar | Tunivar | Tsubst _ | Tconstr _ -> + Misc.may (fun (_,l) -> List.iter f l) row.row_name; +- List.iter f row.row_bound ++ List.iter f row.row_bound; ++ List.iter (fun (s,k,t) -> f t) row.row_object + | _ -> assert false + + let iter_type_expr f ty = +@@ -224,7 +225,9 @@ + | Some (path, tl) -> Some (path, List.map f tl) in + { row_fields = fields; row_more = more; + row_bound = !bound; row_fixed = row.row_fixed && fixed; +- row_closed = row.row_closed; row_name = name; } ++ row_closed = row.row_closed; row_name = name; ++ row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object; ++ } + + let rec copy_kind = function + Fvar{contents = Some k} -> copy_kind k +Index: ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.197.2.6 +diff -u -r1.197.2.6 ctype.ml +--- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6 ++++ ctype.ml 16 Jan 2006 02:23:15 -0000 +@@ -1421,7 +1421,7 @@ + newgenty + (Tvariant + {row_fields = fields; row_closed = closed; row_more = newvar(); +- row_bound = []; row_fixed = false; row_name = None }) ++ row_bound = []; row_fixed = false; row_name = None; row_object=[]}) + + (**** Unification ****) + +@@ -1724,8 +1724,11 @@ + else None + in + let bound = row1.row_bound @ row2.row_bound in ++ let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in ++ let row_object = row1.row_object @ miss2 in + let row0 = {row_fields = []; row_more = more; row_bound = bound; +- row_closed = closed; row_fixed = fixed; row_name = name} in ++ row_closed = closed; row_fixed = fixed; row_name = name; ++ row_object = row_object } in + let set_more row rest = + let rest = + if closed then +@@ -1758,6 +1761,18 @@ + raise (Unify ((mkvariant [l,f1] true, + mkvariant [l,f2] true) :: trace))) + pairs; ++ List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs; ++ if row_object <> [] then begin ++ List.iter ++ (fun (l,f) -> ++ match row_field_repr f with ++ Rpresent (Some ty) -> ++ let fi = build_fields generic_level row_object (newgenvar()) in ++ unify env (newgenty (Tobject (fi, ref None))) ty ++ | Rpresent None -> raise (Unify []) ++ | _ -> ()) ++ (row_repr row1).row_fields ++ end; + with exn -> + log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn + end +@@ -2789,7 +2804,8 @@ + let row = + { row_fields = List.map fst fields; row_more = newvar(); + row_bound = !bound; row_closed = posi; row_fixed = false; +- row_name = if c > Unchanged then None else row.row_name } ++ row_name = if c > Unchanged then None else row.row_name; ++ row_object = [] } + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> +Index: oprint.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v +retrieving revision 1.22 +diff -u -r1.22 oprint.ml +--- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 ++++ oprint.ml 16 Jan 2006 02:23:15 -0000 +@@ -185,7 +185,7 @@ + fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields + | Otyp_stuff s -> fprintf ppf "%s" s + | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s +- | Otyp_variant (non_gen, row_fields, closed, tags) -> ++ | Otyp_variant (non_gen, row_fields, closed, tags, obj) -> + let print_present ppf = + function + None | Some [] -> () +@@ -198,12 +198,17 @@ + ppf fields + | Ovar_name (id, tyl) -> + fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ++ and print_object ppf obj = ++ if obj <> [] then ++ fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj + in +- fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") ++ fprintf ppf "%s[%s@[@[%a@]%a%a ]@]" ++ (if non_gen then "_" else "") + (if closed then if tags = None then " " else "< " + else if tags = None then "> " else "? ") + print_fields row_fields + print_present tags ++ print_object obj + | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> + fprintf ppf "@[<1>(%a)@]" print_out_type ty + | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () +Index: outcometree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v +retrieving revision 1.14 +diff -u -r1.14 outcometree.mli +--- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 ++++ outcometree.mli 16 Jan 2006 02:23:15 -0000 +@@ -59,6 +59,7 @@ + | Otyp_var of bool * string + | Otyp_variant of + bool * out_variant * bool * (string list) option ++ * (string * out_type) list + | Otyp_poly of string list * out_type + and out_variant = + | Ovar_fields of (string * bool * out_type list) list +Index: printtyp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v +retrieving revision 1.139.2.2 +diff -u -r1.139.2.2 printtyp.ml +--- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2 ++++ printtyp.ml 16 Jan 2006 02:23:15 -0000 +@@ -244,7 +244,10 @@ + visited_objects := px :: !visited_objects; + match row.row_name with + | Some(p, tyl) when namable_row row -> +- List.iter (mark_loops_rec visited) tyl ++ List.iter (mark_loops_rec visited) tyl; ++ if not (static_row row) then ++ List.iter (fun (s,k,t) -> mark_loops_rec visited t) ++ row.row_object + | _ -> + iter_row (mark_loops_rec visited) {row with row_bound = []} + end +@@ -343,25 +346,27 @@ + | _ -> false) + fields in + let all_present = List.length present = List.length fields in ++ let static = row.row_closed && all_present in ++ let obj = ++ if static then [] else ++ List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object ++ in ++ let tags = if all_present then None else Some (List.map fst present) in + begin match row.row_name with + | Some(p, tyl) when namable_row row -> + let id = tree_of_path p in + let args = tree_of_typlist sch tyl in +- if row.row_closed && all_present then ++ if static then + Otyp_constr (id, args) + else + let non_gen = is_non_gen sch px in +- let tags = +- if all_present then None else Some (List.map fst present) in + Otyp_variant (non_gen, Ovar_name(tree_of_path p, args), +- row.row_closed, tags) ++ row.row_closed, tags, obj) + | _ -> +- let non_gen = +- not (row.row_closed && all_present) && is_non_gen sch px in ++ let non_gen = not static && is_non_gen sch px in + let fields = List.map (tree_of_row_field sch) fields in +- let tags = +- if all_present then None else Some (List.map fst present) in +- Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) ++ Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, ++ tags, obj) + end + | Tobject (fi, nm) -> + tree_of_typobject sch fi nm +Index: typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.176.2.2 +diff -u -r1.176.2.2 typecore.ml +--- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2 ++++ typecore.ml 16 Jan 2006 02:23:15 -0000 +@@ -170,7 +170,8 @@ + (* Force check of well-formedness *) + unify_pat pat.pat_env pat + (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; +- row_bound=[]; row_fixed=false; row_name=None})); ++ row_bound=[]; row_fixed=false; row_name=None; ++ row_object=[]})); + | _ -> () + + let rec iter_pattern f p = +@@ -251,7 +252,7 @@ + let ty = may_map (build_as_type env) p' in + newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); + row_bound=[]; row_name=None; +- row_fixed=false; row_closed=false}) ++ row_fixed=false; row_closed=false; row_object=[]}) + | Tpat_record lpl -> + let lbl = fst(List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type else +@@ -318,7 +319,8 @@ + ([],[]) fields in + let row = + { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound; +- row_closed = false; row_fixed = false; row_name = Some (path, tyl) } ++ row_closed = false; row_fixed = false; row_name = Some (path, tyl); ++ row_object = [] } + in + let ty = newty (Tvariant row) in + let gloc = {loc with Location.loc_ghost=true} in +@@ -428,7 +430,8 @@ + row_closed = false; + row_more = newvar (); + row_fixed = false; +- row_name = None } in ++ row_name = None; ++ row_object = [] } in + rp { + pat_desc = Tpat_variant(l, arg, row); + pat_loc = sp.ppat_loc; +@@ -976,7 +979,8 @@ + row_bound = []; + row_closed = false; + row_fixed = false; +- row_name = None}); ++ row_name = None; ++ row_object = []}); + exp_env = env } + | Pexp_record(lid_sexp_list, opt_sexp) -> + let ty = newvar() in +@@ -1261,8 +1265,30 @@ + assert false + end + | _ -> +- (Texp_send(obj, Tmeth_name met), +- filter_method env met Public obj.exp_type) ++ let obj, met_ty = ++ match expand_head env obj.exp_type with ++ {desc = Tvariant _} -> ++ let exp_ty = newvar () in ++ let met_ty = filter_method env met Public exp_ty in ++ let row = ++ {row_fields=[]; row_more=newvar(); ++ row_bound=[]; row_closed=false; ++ row_fixed=false; row_name=None; ++ row_object=[met, Fpresent, met_ty]} in ++ unify_exp env obj (newty (Tvariant row)); ++ let prim = Primitive.parse_declaration 1 ["%field1"] in ++ let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in ++ let vd = {val_type = ty; val_kind = Val_prim prim} in ++ let esnd = ++ {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd); ++ exp_loc = Location.none; exp_type = ty; exp_env = env} ++ in ++ ({obj with exp_type = exp_ty; ++ exp_desc = Texp_apply(esnd,[Some obj, Required])}, ++ met_ty) ++ | _ -> (obj, filter_method env met Public obj.exp_type) ++ in ++ (Texp_send(obj, Tmeth_name met), met_ty) + in + if !Clflags.principal then begin + end_def (); +Index: types.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v +retrieving revision 1.25 +diff -u -r1.25 types.ml +--- types.ml 9 Dec 2004 12:40:53 -0000 1.25 ++++ types.ml 16 Jan 2006 02:23:15 -0000 +@@ -44,7 +44,9 @@ + row_bound: type_expr list; + row_closed: bool; + row_fixed: bool; +- row_name: (Path.t * type_expr list) option } ++ row_name: (Path.t * type_expr list) option; ++ row_object: (string * field_kind * type_expr) list; ++ } + + and row_field = + Rpresent of type_expr option +Index: types.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v +retrieving revision 1.25 +diff -u -r1.25 types.mli +--- types.mli 9 Dec 2004 12:40:53 -0000 1.25 ++++ types.mli 16 Jan 2006 02:23:15 -0000 +@@ -43,7 +43,9 @@ + row_bound: type_expr list; + row_closed: bool; + row_fixed: bool; +- row_name: (Path.t * type_expr list) option } ++ row_name: (Path.t * type_expr list) option; ++ row_object: (string * field_kind * type_expr) list; ++ } + + and row_field = + Rpresent of type_expr option +Index: typetexp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v +retrieving revision 1.54 +diff -u -r1.54 typetexp.ml +--- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54 ++++ typetexp.ml 16 Jan 2006 02:23:15 -0000 +@@ -215,7 +215,8 @@ + in + let row = { row_closed = true; row_fields = fields; + row_bound = !bound; row_name = Some (path, args); +- row_fixed = false; row_more = newvar () } in ++ row_fixed = false; row_more = newvar (); ++ row_object = [] } in + let static = Btype.static_row row in + let row = + if static then row else +@@ -262,7 +263,7 @@ + let mkfield l f = + newty (Tvariant {row_fields=[l,f]; row_more=newvar(); + row_bound=[]; row_closed=true; +- row_fixed=false; row_name=None}) in ++ row_fixed=false; row_name=None; row_object=[]}) in + let add_typed_field loc l f fields = + try + let f' = List.assoc l fields in +@@ -345,7 +346,7 @@ + let row = + { row_fields = List.rev fields; row_more = newvar (); + row_bound = !bound; row_closed = closed; +- row_fixed = false; row_name = !name } in ++ row_fixed = false; row_name = !name; row_object = [] } in + let static = Btype.static_row row in + let row = + if static then row else diff --git a/experimental/garrigue/objvariant.ml b/experimental/garrigue/objvariant.ml new file mode 100644 index 00000000..3233e03c --- /dev/null +++ b/experimental/garrigue/objvariant.ml @@ -0,0 +1,42 @@ +(* use with [cvs update -r objvariants typing] *) + +let f (x : [> ]) = x#m 3;; +let o = object method m x = x+2 end;; +f (`A o);; +let l = [`A o; `B(object method m x = x -2 method y = 3 end)];; +List.map f l;; +let g = function `A x -> x#m 3 | `B x -> x#y;; +List.map g l;; +fun x -> ignore (x=f); List.map x l;; +fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;; + + +class cvar name = + object + method name = name + method print ppf = Format.pp_print_string ppf name + end + +type var = [`Var of cvar] + +class cint n = + object + method n = n + method print ppf = Format.pp_print_int ppf n + end + +class ['a] cadd (e1 : 'a) (e2 : 'a) = + object + constraint 'a = [> ] + method e1 = e1 + method e2 = e2 + method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print + end + +type 'a expr = [var | `Int of cint | `Add of 'a cadd] + +type expr1 = expr1 expr + +let print = Format.printf "%t@." + +let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2))) diff --git a/experimental/garrigue/parser-lessminus.diffs b/experimental/garrigue/parser-lessminus.diffs new file mode 100644 index 00000000..7b535307 --- /dev/null +++ b/experimental/garrigue/parser-lessminus.diffs @@ -0,0 +1,77 @@ +Index: parsing/parser.mly +=================================================================== +--- parsing/parser.mly (revision 11929) ++++ parsing/parser.mly (working copy) +@@ -319,6 +319,11 @@ + let polyvars, core_type = varify_constructors newtypes core_type in + (exp, ghtyp(Ptyp_poly(polyvars,core_type))) + ++let no_lessminus = ++ List.map (fun (p,e,b) -> ++ match b with None -> (p,e) ++ | Some loc -> raise (Syntaxerr.Error (Syntaxerr.Other loc))) ++ + %} + + /* Tokens */ +@@ -597,8 +602,9 @@ + structure_item: + LET rec_flag let_bindings + { match $3 with +- [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp) +- | _ -> mkstr(Pstr_value($2, List.rev $3)) } ++ [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp, None] -> ++ mkstr(Pstr_eval exp) ++ | _ -> mkstr(Pstr_value($2, no_lessminus (List.rev $3))) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) } + | TYPE type_declarations +@@ -744,7 +750,7 @@ + | class_simple_expr simple_labeled_expr_list + { mkclass(Pcl_apply($1, List.rev $2)) } + | LET rec_flag let_bindings IN class_expr +- { mkclass(Pcl_let ($2, List.rev $3, $5)) } ++ { mkclass(Pcl_let ($2, no_lessminus (List.rev $3), $5)) } + ; + class_simple_expr: + LBRACKET core_type_comma_list RBRACKET class_longident +@@ -981,9 +987,15 @@ + | simple_expr simple_labeled_expr_list + { mkexp(Pexp_apply($1, List.rev $2)) } + | LET rec_flag let_bindings IN seq_expr +- { mkexp(Pexp_let($2, List.rev $3, $5)) } ++ { match $3 with ++ | [pat, expr, Some loc] when $2 = Nonrecursive -> ++ mkexp(Pexp_apply( ++ {pexp_desc = Pexp_ident(Lident "bind"); pexp_loc = loc}, ++ ["", expr; "", ghexp(Pexp_function("", None, [pat, $5]))])) ++ | bindings -> ++ mkexp(Pexp_let($2, no_lessminus (List.rev $3), $5)) } + | LET DOT simple_expr let_binding IN seq_expr +- { let (pat, expr) = $4 in ++ { let (pat, expr, _) = $4 in + mkexp(Pexp_apply($3, ["", expr; "", ghexp(Pexp_function("", None, [pat, $6]))])) } + | LET MODULE UIDENT module_binding IN seq_expr + { mkexp(Pexp_letmodule($3, $4, $6)) } +@@ -1197,14 +1209,17 @@ + ; + let_binding: + val_ident fun_binding +- { (mkpatvar $1 1, $2) } ++ { (mkpatvar $1 1, $2, None) } + | 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($3,$5)))), $7, ++ None) } + | 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) } ++ (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp, None) } + | pattern EQUAL seq_expr +- { ($1, $3) } ++ { ($1, $3, None) } ++ | pattern LESSMINUS seq_expr ++ { ($1, $3, Some (rhs_loc 2)) } + ; + fun_binding: + strict_binding diff --git a/experimental/garrigue/printers.ml b/experimental/garrigue/printers.ml new file mode 100644 index 00000000..c80c42d6 --- /dev/null +++ b/experimental/garrigue/printers.ml @@ -0,0 +1,11 @@ +(* $Id$ *) + +open Types + +let ignore_abbrevs ppf ab = + let s = match ab with + Mnil -> "Mnil" + | Mlink _ -> "Mlink _" + | Mcons _ -> "Mcons _" + in + Format.pp_print_string ppf s diff --git a/experimental/garrigue/show_types.diffs b/experimental/garrigue/show_types.diffs new file mode 100644 index 00000000..0c291955 --- /dev/null +++ b/experimental/garrigue/show_types.diffs @@ -0,0 +1,160 @@ +Index: typing/printtyp.ml +=================================================================== +--- typing/printtyp.ml (revision 11316) ++++ typing/printtyp.ml (working copy) +@@ -894,8 +894,10 @@ + tree_of_class_declaration id decl rs :: tree_of_signature rem + | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + tree_of_cltype_declaration id decl rs :: tree_of_signature rem +- | _ -> +- assert false ++ | Tsig_class(id, decl, rs) :: _ -> ++ tree_of_class_declaration id decl rs :: [] ++ | Tsig_cltype(id, decl, rs) :: _ -> ++ tree_of_cltype_declaration id decl rs :: [] + + and tree_of_modtype_declaration id decl = + let mty = +Index: toplevel/topdirs.ml +=================================================================== +--- toplevel/topdirs.ml (revision 11316) ++++ toplevel/topdirs.ml (working copy) +@@ -297,10 +297,92 @@ + !traced_functions; + traced_functions := [] + ++(* Warnings *) ++ + let parse_warnings ppf iserr s = + try Warnings.parse_options iserr s + with Arg.Bad err -> fprintf ppf "%s.@." err + ++(* Typing information *) ++ ++type pkind = ++ Pvalue ++ | Ptype ++ | Pexception ++ | Pmodule ++ | Pmodtype ++ | Pclass ++ | Pcltype ++ ++let name_of_kind = function ++ Pvalue -> "value" ++ | Ptype -> "type" ++ | Pexception -> "exception" ++ | Pmodule -> "module" ++ | Pmodtype -> "module type" ++ | Pclass -> "class" ++ | Pcltype -> "class type" ++ ++let rec trim_modtype = function ++ Tmty_signature _ -> Tmty_signature [] ++ | Tmty_functor (id, mty, mty') -> ++ Tmty_functor (id, mty, trim_modtype mty') ++ | Tmty_ident _ as mty -> mty ++ ++let trim_signature = function ++ Tmty_signature sg -> ++ Tmty_signature ++ (List.map ++ (function ++ Tsig_module (id, mty, rs) -> ++ Tsig_module (id, trim_modtype mty, rs) ++ (*| Tsig_modtype (id, Tmodtype_manifest mty) -> ++ Tsig_modtype (id, Tmodtype_manifest (trim_modtype mty))*) ++ | item -> item) ++ sg) ++ | mty -> mty ++ ++let show_type ppf kind lid = ++ let env = !Toploop.toplevel_env in ++ try ++ let id = ++ let s = match lid with ++ Longident.Lident s -> s ++ | Longident.Ldot (_,s) -> s ++ | Longident.Lapply _ -> failwith "invalid" ++ in Ident.create_persistent s ++ in ++ let item = ++ match kind with ++ Pvalue -> ++ let path, desc = Env.lookup_value lid env in ++ Tsig_value (id, desc) ++ | Ptype -> ++ let path, desc = Env.lookup_type lid env in ++ Tsig_type (id, desc, Trec_not) ++ | Pexception -> ++ let desc = Env.lookup_constructor lid env in ++ Tsig_exception (id, desc.cstr_args) ++ | Pmodule -> ++ let path, desc = Env.lookup_module lid env in ++ Tsig_module (id, trim_signature desc, Trec_not) ++ | Pmodtype -> ++ let path, desc = Env.lookup_modtype lid env in ++ Tsig_modtype (id, desc) ++ | Pclass -> ++ let path, desc = Env.lookup_class lid env in ++ Tsig_class (id, desc, Trec_not) ++ | Pcltype -> ++ let path, desc = Env.lookup_cltype lid env in ++ Tsig_cltype (id, desc, Trec_not) ++ in ++ fprintf ppf "%a@." Printtyp.signature [item] ++ with ++ Not_found -> ++ fprintf ppf "Unknown %s.@." (name_of_kind kind) ++ | Failure "invalid" -> ++ fprintf ppf "Invalid path %a@." Printtyp.longident lid ++ + let _ = + Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out)); + Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out)); +@@ -329,4 +411,19 @@ + (Directive_string (parse_warnings std_out false)); + + Hashtbl.add directive_table "warn_error" +- (Directive_string (parse_warnings std_out true)) ++ (Directive_string (parse_warnings std_out true)); ++ ++ Hashtbl.add directive_table "show_value" ++ (Directive_ident (show_type std_out Pvalue)); ++ Hashtbl.add directive_table "show_type" ++ (Directive_ident (show_type std_out Ptype)); ++ Hashtbl.add directive_table "show_exception" ++ (Directive_ident (show_type std_out Pexception)); ++ Hashtbl.add directive_table "show_module" ++ (Directive_ident (show_type std_out Pmodule)); ++ Hashtbl.add directive_table "show_module_type" ++ (Directive_ident (show_type std_out Pmodtype)); ++ Hashtbl.add directive_table "show_class" ++ (Directive_ident (show_type std_out Pclass)); ++ Hashtbl.add directive_table "show_class_type" ++ (Directive_ident (show_type std_out Pcltype)) +Index: parsing/parser.mly +=================================================================== +--- parsing/parser.mly (revision 11316) ++++ parsing/parser.mly (working copy) +@@ -1769,6 +1769,11 @@ + LIDENT { Lident $1 } + | mod_longident DOT LIDENT { Ldot($1, $3) } + ; ++any_longident: ++ val_ident { Lident $1 } ++ | mod_longident DOT val_ident { Ldot($1, $3) } ++ | mod_longident { $1 } ++; + + /* Toplevel directives */ + +@@ -1776,7 +1781,7 @@ + SHARP ident { Ptop_dir($2, Pdir_none) } + | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) } + | SHARP ident INT { Ptop_dir($2, Pdir_int $3) } +- | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) } ++ | SHARP ident any_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) } + | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) } + ; diff --git a/experimental/garrigue/tests.ml b/experimental/garrigue/tests.ml new file mode 100644 index 00000000..c39d152f --- /dev/null +++ b/experimental/garrigue/tests.ml @@ -0,0 +1,22 @@ +(* $Id$ *) + +let f1 = function `a x -> x=1 | `b -> true +let f2 = function `a x -> x | `b -> true +let f3 = function `b -> true +let f x = f1 x && f2 x + +let sub s ?:pos{=0} ?:len{=String.length s - pos} () = + String.sub s pos len + +let cCAMLtoTKpack_options w = function + `After v1 -> "-after" + | `Anchor v1 -> "-anchor" + | `Before v1 -> "-before" + | `Expand v1 -> "-expand" + | `Fill v1 -> "-fill" + | `In v1 -> "-in" + | `Ipadx v1 -> "-ipadx" + | `Ipady v1 -> "-ipady" + | `Padx v1 -> "-padx" + | `Pady v1 -> "-pady" + | `Side v1 -> "-side" diff --git a/experimental/garrigue/valvirt.diffs b/experimental/garrigue/valvirt.diffs new file mode 100644 index 00000000..2cf55742 --- /dev/null +++ b/experimental/garrigue/valvirt.diffs @@ -0,0 +1,2349 @@ +Index: utils/warnings.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v +retrieving revision 1.23 +diff -u -r1.23 warnings.ml +--- utils/warnings.ml 15 Sep 2005 03:09:26 -0000 1.23 ++++ utils/warnings.ml 5 Apr 2006 02:25:59 -0000 +@@ -26,7 +26,7 @@ + | Statement_type (* S *) + | Unused_match (* U *) + | Unused_pat +- | Hide_instance_variable of string (* V *) ++ | Instance_variable_override of string (* V *) + | Illegal_backslash (* X *) + | Implicit_public_methods of string list + | Unerasable_optional_argument +@@ -54,7 +54,7 @@ + | Statement_type -> 's' + | Unused_match + | Unused_pat -> 'u' +- | Hide_instance_variable _ -> 'v' ++ | Instance_variable_override _ -> 'v' + | Illegal_backslash + | Implicit_public_methods _ + | Unerasable_optional_argument +@@ -126,9 +126,9 @@ + String.concat " " + ("the following methods are overridden \ + by the inherited class:\n " :: slist) +- | Hide_instance_variable lab -> +- "this definition of an instance variable " ^ lab ^ +- " hides a previously\ndefined instance variable of the same name." ++ | Instance_variable_override lab -> ++ "the instance variable " ^ lab ^ " is overridden.\n" ^ ++ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + | Partial_application -> + "this function application is partial,\n\ + maybe some arguments are missing." +Index: utils/warnings.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v +retrieving revision 1.16 +diff -u -r1.16 warnings.mli +--- utils/warnings.mli 15 Sep 2005 03:09:26 -0000 1.16 ++++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000 +@@ -26,7 +26,7 @@ + | Statement_type (* S *) + | Unused_match (* U *) + | Unused_pat +- | Hide_instance_variable of string (* V *) ++ | Instance_variable_override of string (* V *) + | Illegal_backslash (* X *) + | Implicit_public_methods of string list + | Unerasable_optional_argument +Index: parsing/parser.mly +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v +retrieving revision 1.123 +diff -u -r1.123 parser.mly +--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123 ++++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000 +@@ -623,6 +623,8 @@ + { [] } + | class_fields INHERIT class_expr parent_binder + { Pcf_inher ($3, $4) :: $1 } ++ | class_fields VAL virtual_value ++ { Pcf_valvirt $3 :: $1 } + | class_fields VAL value + { Pcf_val $3 :: $1 } + | class_fields virtual_method +@@ -638,14 +640,20 @@ + AS LIDENT + { Some $2 } + | /* empty */ +- {None} ++ { None } ++; ++virtual_value: ++ MUTABLE VIRTUAL label COLON core_type ++ { $3, Mutable, $5, symbol_rloc () } ++ | VIRTUAL mutable_flag label COLON core_type ++ { $3, $2, $5, symbol_rloc () } + ; + value: +- mutable_flag label EQUAL seq_expr +- { $2, $1, $4, symbol_rloc () } +- | mutable_flag label type_constraint EQUAL seq_expr +- { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), +- symbol_rloc () } ++ mutable_flag label EQUAL seq_expr ++ { $2, $1, $4, symbol_rloc () } ++ | mutable_flag label type_constraint EQUAL seq_expr ++ { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), ++ symbol_rloc () } + ; + virtual_method: + METHOD PRIVATE VIRTUAL label COLON poly_type +@@ -711,8 +719,12 @@ + | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 } + ; + value_type: +- mutable_flag label COLON core_type +- { $2, $1, Some $4, symbol_rloc () } ++ VIRTUAL mutable_flag label COLON core_type ++ { $3, $2, Virtual, $5, symbol_rloc () } ++ | MUTABLE virtual_flag label COLON core_type ++ { $3, Mutable, $2, $5, symbol_rloc () } ++ | label COLON core_type ++ { $1, Immutable, Concrete, $3, symbol_rloc () } + ; + method_type: + METHOD private_flag label COLON poly_type +Index: parsing/parsetree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v +retrieving revision 1.42 +diff -u -r1.42 parsetree.mli +--- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42 ++++ parsing/parsetree.mli 5 Apr 2006 02:25:59 -0000 +@@ -152,7 +152,7 @@ + + and class_type_field = + Pctf_inher of class_type +- | Pctf_val of (string * mutable_flag * core_type option * Location.t) ++ | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t) + | Pctf_virt of (string * private_flag * core_type * Location.t) + | Pctf_meth of (string * private_flag * core_type * Location.t) + | Pctf_cstr of (core_type * core_type * Location.t) +@@ -179,6 +179,7 @@ + + and class_field = + Pcf_inher of class_expr * string option ++ | Pcf_valvirt of (string * mutable_flag * core_type * Location.t) + | Pcf_val of (string * mutable_flag * expression * Location.t) + | Pcf_virt of (string * private_flag * core_type * Location.t) + | Pcf_meth of (string * private_flag * expression * Location.t) +Index: parsing/printast.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v +retrieving revision 1.29 +diff -u -r1.29 printast.ml +--- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29 ++++ parsing/printast.ml 5 Apr 2006 02:25:59 -0000 +@@ -353,10 +353,11 @@ + | Pctf_inher (ct) -> + line i ppf "Pctf_inher\n"; + class_type i ppf ct; +- | Pctf_val (s, mf, cto, loc) -> ++ | Pctf_val (s, mf, vf, ct, loc) -> + line i ppf +- "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; +- option i core_type ppf cto; ++ "Pctf_val \"%s\" %a %a %a\n" s ++ fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; ++ core_type (i+1) ppf ct; + | Pctf_virt (s, pf, ct, loc) -> + line i ppf + "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; +@@ -428,6 +429,10 @@ + line i ppf "Pcf_inher\n"; + class_expr (i+1) ppf ce; + option (i+1) string ppf so; ++ | Pcf_valvirt (s, mf, ct, loc) -> ++ line i ppf ++ "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; ++ core_type (i+1) ppf ct; + | Pcf_val (s, mf, e, loc) -> + line i ppf + "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; +Index: typing/btype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v +retrieving revision 1.38 +diff -u -r1.38 btype.ml +--- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38 ++++ typing/btype.ml 5 Apr 2006 02:25:59 -0000 +@@ -330,7 +330,7 @@ + + let unmark_class_signature sign = + unmark_type sign.cty_self; +- Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars ++ Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars + + let rec unmark_class_type = + function +Index: typing/ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.200 +diff -u -r1.200 ctype.ml +--- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200 ++++ typing/ctype.ml 5 Apr 2006 02:25:59 -0000 +@@ -857,7 +857,7 @@ + Tcty_signature + {cty_self = copy sign.cty_self; + cty_vars = +- Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars; ++ Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars; + cty_concr = sign.cty_concr; + cty_inher = + List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher} +@@ -2354,10 +2354,11 @@ + | CM_Val_type_mismatch of string * (type_expr * type_expr) list + | CM_Meth_type_mismatch of string * (type_expr * type_expr) list + | CM_Non_mutable_value of string ++ | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string +- | CM_Hide_virtual of string ++ | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string +@@ -2390,8 +2391,8 @@ + end) + pairs; + Vars.iter +- (fun lab (mut, ty) -> +- let (mut', ty') = Vars.find lab sign1.cty_vars in ++ (fun lab (mut, v, ty) -> ++ 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)])) +@@ -2437,7 +2438,7 @@ + end + in + if Concr.mem lab sign1.cty_concr then err +- else CM_Hide_virtual lab::err) ++ else CM_Hide_virtual ("method", lab) :: err) + miss1 [] + in + let missing_method = List.map (fun (m, _, _) -> m) miss2 in +@@ -2455,11 +2456,13 @@ + in + let error = + Vars.fold +- (fun lab (mut, ty) err -> ++ (fun lab (mut, vr, ty) err -> + try +- let (mut', ty') = Vars.find lab sign1.cty_vars in ++ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in + if mut = Mutable && mut' <> Mutable then + CM_Non_mutable_value lab::err ++ else if vr = Concrete && vr' <> Concrete then ++ CM_Non_concrete_value lab::err + else + err + with Not_found -> +@@ -2467,6 +2470,14 @@ + sign2.cty_vars error + in + let error = ++ Vars.fold ++ (fun lab (_,vr,_) err -> ++ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then ++ CM_Hide_virtual ("instance variable", lab) :: err ++ else err) ++ sign1.cty_vars error ++ in ++ let error = + List.fold_right + (fun e l -> + if List.mem e missing_method then l else CM_Virtual_method e::l) +@@ -2516,8 +2527,8 @@ + end) + pairs; + Vars.iter +- (fun lab (mut, ty) -> +- let (mut', ty') = Vars.find lab sign1.cty_vars in ++ (fun lab (_, _, ty) -> ++ 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)])) +@@ -2554,7 +2565,7 @@ + end + in + if Concr.mem lab sign1.cty_concr then err +- else CM_Hide_virtual lab::err) ++ else CM_Hide_virtual ("method", lab) :: err) + miss1 [] + in + let missing_method = List.map (fun (m, _, _) -> m) miss2 in +@@ -2578,11 +2589,13 @@ + in + let error = + Vars.fold +- (fun lab (mut, ty) err -> ++ (fun lab (mut, vr, ty) err -> + try +- let (mut', ty') = Vars.find lab sign1.cty_vars in ++ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in + if mut = Mutable && mut' <> Mutable then + CM_Non_mutable_value lab::err ++ else if vr = Concrete && vr' <> Concrete then ++ CM_Non_concrete_value lab::err + else + err + with Not_found -> +@@ -2590,6 +2603,14 @@ + sign2.cty_vars error + in + let error = ++ Vars.fold ++ (fun lab (_,vr,_) err -> ++ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then ++ CM_Hide_virtual ("instance variable", lab) :: err ++ else err) ++ sign1.cty_vars error ++ in ++ let error = + List.fold_right + (fun e l -> + if List.mem e missing_method then l else CM_Virtual_method e::l) +@@ -3279,7 +3300,7 @@ + let nondep_class_signature env id sign = + { cty_self = nondep_type_rec env id sign.cty_self; + cty_vars = +- Vars.map (function (m, t) -> (m, nondep_type_rec env id t)) ++ Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + sign.cty_vars; + cty_concr = sign.cty_concr; + cty_inher = +Index: typing/ctype.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v +retrieving revision 1.53 +diff -u -r1.53 ctype.mli +--- typing/ctype.mli 9 Dec 2004 12:40:53 -0000 1.53 ++++ typing/ctype.mli 5 Apr 2006 02:25:59 -0000 +@@ -170,10 +170,11 @@ + | CM_Val_type_mismatch of string * (type_expr * type_expr) list + | CM_Meth_type_mismatch of string * (type_expr * type_expr) list + | CM_Non_mutable_value of string ++ | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string +- | CM_Hide_virtual of string ++ | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string +Index: typing/includeclass.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v +retrieving revision 1.7 +diff -u -r1.7 includeclass.ml +--- typing/includeclass.ml 6 Mar 2000 22:11:57 -0000 1.7 ++++ typing/includeclass.ml 5 Apr 2006 02:25:59 -0000 +@@ -78,14 +78,17 @@ + | CM_Non_mutable_value lab -> + fprintf ppf + "@[The non-mutable instance variable %s cannot become mutable@]" lab ++ | CM_Non_concrete_value lab -> ++ fprintf ppf ++ "@[The virtual instance variable %s cannot become concrete@]" lab + | CM_Missing_value lab -> + fprintf ppf "@[The first class type has no instance variable %s@]" lab + | CM_Missing_method lab -> + fprintf ppf "@[The first class type has no method %s@]" lab + | CM_Hide_public lab -> + fprintf ppf "@[The public method %s cannot be hidden@]" lab +- | CM_Hide_virtual lab -> +- fprintf ppf "@[The virtual method %s cannot be hidden@]" lab ++ | CM_Hide_virtual (k, lab) -> ++ fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab + | CM_Public_method lab -> + fprintf ppf "@[The public method %s cannot become private" lab + | CM_Virtual_method lab -> +Index: typing/oprint.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v +retrieving revision 1.22 +diff -u -r1.22 oprint.ml +--- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 ++++ typing/oprint.ml 5 Apr 2006 02:25:59 -0000 +@@ -291,8 +291,10 @@ + fprintf ppf "@[<2>method %s%s%s :@ %a@]" + (if priv then "private " else "") (if virt then "virtual " else "") + name !out_type ty +- | Ocsg_value (name, mut, ty) -> +- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") ++ | Ocsg_value (name, mut, vr, ty) -> ++ fprintf ppf "@[<2>val %s%s%s :@ %a@]" ++ (if mut then "mutable " else "") ++ (if vr then "virtual " else "") + name !out_type ty + + let out_class_type = ref print_out_class_type +Index: typing/outcometree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v +retrieving revision 1.14 +diff -u -r1.14 outcometree.mli +--- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 ++++ typing/outcometree.mli 5 Apr 2006 02:25:59 -0000 +@@ -71,7 +71,7 @@ + and out_class_sig_item = + | Ocsg_constraint of out_type * out_type + | Ocsg_method of string * bool * bool * out_type +- | Ocsg_value of string * bool * out_type ++ | Ocsg_value of string * bool * bool * out_type + + type out_module_type = + | Omty_abstract +Index: typing/printtyp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v +retrieving revision 1.140 +diff -u -r1.140 printtyp.ml +--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140 ++++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000 +@@ -650,7 +650,7 @@ + Ctype.flatten_fields (Ctype.object_fields sign.cty_self) + in + List.iter (fun met -> mark_loops (method_type met)) fields; +- Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars ++ Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars + | Tcty_fun (_, ty, cty) -> + mark_loops ty; + prepare_class_type params cty +@@ -682,13 +682,15 @@ + csil (tree_of_constraints params) + in + let all_vars = +- Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in ++ Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars [] ++ in + (* Consequence of PR#3607: order of Map.fold has changed! *) + let all_vars = List.rev all_vars in + let csil = + List.fold_left +- (fun csil (l, m, t) -> +- Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil) ++ (fun csil (l, m, v, t) -> ++ Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) ++ :: csil) + csil all_vars + in + let csil = +@@ -763,7 +765,9 @@ + List.exists + (fun (lab, _, ty) -> + not (lab = dummy_method || Concr.mem lab sign.cty_concr)) +- fields in ++ fields ++ || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false ++ in + + Osig_class_type + (virt, Ident.name id, +Index: typing/subst.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v +retrieving revision 1.49 +diff -u -r1.49 subst.ml +--- typing/subst.ml 4 Jan 2006 16:55:50 -0000 1.49 ++++ typing/subst.ml 5 Apr 2006 02:26:00 -0000 +@@ -178,7 +178,8 @@ + + let class_signature s sign = + { cty_self = typexp s sign.cty_self; +- cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars; ++ cty_vars = ++ Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars; + cty_concr = sign.cty_concr; + cty_inher = + List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) +Index: typing/typeclass.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v +retrieving revision 1.85 +diff -u -r1.85 typeclass.ml +--- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85 ++++ typing/typeclass.ml 5 Apr 2006 02:26:00 -0000 +@@ -24,7 +24,7 @@ + + type error = + Unconsistent_constraint of (type_expr * type_expr) list +- | Method_type_mismatch of string * (type_expr * type_expr) list ++ | Field_type_mismatch of string * string * (type_expr * type_expr) list + | Structure_expected of class_type + | Cannot_apply of class_type + | Apply_wrong_label of label +@@ -36,7 +36,7 @@ + | Unbound_class_type_2 of Longident.t + | Abbrev_type_clash of type_expr * type_expr * type_expr + | Constructor_type_mismatch of string * (type_expr * type_expr) list +- | Virtual_class of bool * string list ++ | Virtual_class of bool * string list * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of (type_expr * type_expr) list + | Bad_parameters of Ident.t * type_expr * type_expr +@@ -49,6 +49,7 @@ + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * (type_expr * type_expr) list + | Final_self_clash of (type_expr * type_expr) list ++ | Mutability_mismatch of string * mutable_flag + + exception Error of Location.t * error + +@@ -90,7 +91,7 @@ + generalize_class_type cty + | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> + Ctype.generalize sty; +- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars; ++ Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars; + List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher + | Tcty_fun (_, ty, cty) -> + Ctype.generalize ty; +@@ -152,7 +153,7 @@ + | Tcty_signature sign -> + Ctype.closed_schema sign.cty_self + && +- Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc) ++ Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) + sign.cty_vars + true + | Tcty_fun (_, ty, cty) -> +@@ -172,7 +173,7 @@ + limited_generalize rv cty + | Tcty_signature sign -> + Ctype.limited_generalize rv sign.cty_self; +- Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty) ++ Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) + sign.cty_vars; + List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) + sign.cty_inher +@@ -201,11 +202,25 @@ + Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env) + + (* Enter an instance variable in the environment *) +-let enter_val cl_num vars lab mut ty val_env met_env par_env = +- let (id, val_env, met_env, par_env) as result = +- enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env ++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))); ++ Ctype.unify val_env (Ctype.instance ty) (Ctype.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))) ++ | Not_found -> None, virt ++ in ++ let (id, _, _, _) as result = ++ match id with Some id -> (id, val_env, met_env, par_env) ++ | None -> ++ enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env + in +- vars := Vars.add lab (id, mut, ty) !vars; ++ vars := Vars.add lab (id, mut, virt, ty) !vars; + result + + let inheritance self_type env concr_meths warn_meths loc parent = +@@ -218,7 +233,7 @@ + with Ctype.Unify trace -> + match trace with + _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> +- raise(Error(loc, Method_type_mismatch (n, rem))) ++ raise(Error(loc, Field_type_mismatch ("method", n, rem))) + | _ -> + assert false + end; +@@ -243,7 +258,7 @@ + in + let ty = transl_simple_type val_env false sty in + try Ctype.unify val_env ty ty' with Ctype.Unify trace -> +- raise(Error(loc, Method_type_mismatch (lab, trace))) ++ raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + + let delayed_meth_specs = ref [] + +@@ -253,7 +268,7 @@ + in + let unif ty = + try Ctype.unify val_env ty ty' with Ctype.Unify trace -> +- raise(Error(loc, Method_type_mismatch (lab, trace))) ++ raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + in + match sty.ptyp_desc, priv with + Ptyp_poly ([],sty), Public -> +@@ -279,6 +294,15 @@ + + (*******************************) + ++let add_val env loc lab (mut, virt, ty) val_sig = ++ let virt = ++ try ++ let (mut', virt', ty') = Vars.find lab val_sig in ++ if virt' = Concrete then virt' else virt ++ with Not_found -> virt ++ in ++ Vars.add lab (mut, virt, ty) val_sig ++ + let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = + function + Pctf_inher sparent -> +@@ -293,25 +317,12 @@ + parent + in + let val_sig = +- Vars.fold +- (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig) +- cl_sig.cty_vars val_sig +- in ++ Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in + (val_sig, concr_meths, inher) + +- | Pctf_val (lab, mut, sty_opt, loc) -> +- let (mut, ty) = +- match sty_opt with +- None -> +- let (mut', ty) = +- try Vars.find lab val_sig with Not_found -> +- raise(Error(loc, Unbound_val lab)) +- in +- (if mut = Mutable then mut' else Immutable), ty +- | Some sty -> +- mut, transl_simple_type env false sty +- in +- (Vars.add lab (mut, ty) val_sig, concr_meths, inher) ++ | Pctf_val (lab, mut, virt, sty, loc) -> ++ let ty = transl_simple_type env false sty in ++ (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher) + + | Pctf_virt (lab, priv, sty, loc) -> + declare_method env meths self_type lab priv sty loc; +@@ -397,7 +408,7 @@ + + let rec class_field cl_num self_type meths vars + (val_env, met_env, par_env, fields, concr_meths, warn_meths, +- inh_vals, inher) = ++ warn_vals, inher) = + function + Pcf_inher (sparent, super) -> + let parent = class_expr cl_num val_env par_env sparent in +@@ -411,18 +422,23 @@ + parent.cl_type + in + (* Variables *) +- let (val_env, met_env, par_env, inh_vars, inh_vals) = ++ let (val_env, met_env, par_env, inh_vars, warn_vals) = + Vars.fold +- (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) -> ++ (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) -> ++ let mut, vr, ty = info in + let (id, val_env, met_env, par_env) = +- enter_val cl_num vars lab mut ty val_env met_env par_env ++ enter_val cl_num vars true lab mut vr ty val_env met_env par_env ++ sparent.pcl_loc + in +- if StringSet.mem lab inh_vals then +- Location.prerr_warning sparent.pcl_loc +- (Warnings.Hide_instance_variable lab); +- (val_env, met_env, par_env, (lab, id) :: inh_vars, +- StringSet.add lab inh_vals)) +- cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals) ++ let warn_vals = ++ if vr = Virtual then warn_vals else ++ if StringSet.mem lab warn_vals then ++ (Location.prerr_warning sparent.pcl_loc ++ (Warnings.Instance_variable_override lab); warn_vals) ++ else StringSet.add lab warn_vals ++ in ++ (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals)) ++ cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals) + in + (* Inherited concrete methods *) + let inh_meths = +@@ -443,11 +459,26 @@ + in + (val_env, met_env, par_env, + lazy(Cf_inher (parent, inh_vars, inh_meths))::fields, +- concr_meths, warn_meths, inh_vals, inher) ++ concr_meths, warn_meths, warn_vals, inher) ++ ++ | Pcf_valvirt (lab, mut, styp, loc) -> ++ if !Clflags.principal then Ctype.begin_def (); ++ let ty = Typetexp.transl_simple_type val_env false styp in ++ if !Clflags.principal then begin ++ Ctype.end_def (); ++ Ctype.generalize_structure ty ++ end; ++ let (id, val_env, met_env', par_env) = ++ enter_val cl_num vars false lab mut Virtual ty ++ val_env met_env par_env loc ++ in ++ (val_env, met_env', par_env, ++ lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields, ++ concr_meths, warn_meths, StringSet.remove lab warn_vals, inher) + + | Pcf_val (lab, mut, sexp, loc) -> +- if StringSet.mem lab inh_vals then +- Location.prerr_warning loc (Warnings.Hide_instance_variable lab); ++ if StringSet.mem lab warn_vals then ++ Location.prerr_warning loc (Warnings.Instance_variable_override lab); + if !Clflags.principal then Ctype.begin_def (); + let exp = + try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> +@@ -457,17 +488,19 @@ + Ctype.end_def (); + Ctype.generalize_structure exp.exp_type + end; +- let (id, val_env, met_env, par_env) = +- enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env +- in +- (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields, +- concr_meths, warn_meths, inh_vals, inher) ++ let (id, val_env, met_env', par_env) = ++ enter_val cl_num vars false lab mut Concrete exp.exp_type ++ val_env met_env par_env loc ++ in ++ (val_env, met_env', par_env, ++ lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields, ++ concr_meths, warn_meths, StringSet.add lab warn_vals, inher) + + | Pcf_virt (lab, priv, sty, loc) -> + virtual_method val_env meths self_type lab priv sty loc; + let warn_meths = Concr.remove lab warn_meths in + (val_env, met_env, par_env, fields, concr_meths, warn_meths, +- inh_vals, inher) ++ warn_vals, inher) + + | Pcf_meth (lab, priv, expr, loc) -> + let (_, ty) = +@@ -493,7 +526,7 @@ + end + | _ -> assert false + with Ctype.Unify trace -> +- raise(Error(loc, Method_type_mismatch (lab, trace))) ++ raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + end; + let meth_expr = make_method cl_num expr in + (* backup variables for Pexp_override *) +@@ -510,12 +543,12 @@ + Cf_meth (lab, texp) + end in + (val_env, met_env, par_env, field::fields, +- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher) ++ Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher) + + | Pcf_cstr (sty, sty', loc) -> + type_constraint val_env sty sty' loc; + (val_env, met_env, par_env, fields, concr_meths, warn_meths, +- inh_vals, inher) ++ warn_vals, inher) + + | Pcf_let (rec_flag, sdefs, loc) -> + let (defs, val_env) = +@@ -545,7 +578,7 @@ + ([], met_env, par_env) + in + (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields, +- concr_meths, warn_meths, inh_vals, inher) ++ concr_meths, warn_meths, warn_vals, inher) + + | Pcf_init expr -> + let expr = make_method cl_num expr in +@@ -562,7 +595,7 @@ + Cf_init texp + end in + (val_env, met_env, par_env, field::fields, +- concr_meths, warn_meths, inh_vals, inher) ++ concr_meths, warn_meths, warn_vals, inher) + + and class_structure cl_num final val_env met_env loc (spat, str) = + (* Environment for substructures *) +@@ -616,7 +649,7 @@ + Ctype.unify val_env self_type (Ctype.newvar ()); + let sign = + {cty_self = public_self; +- cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars; ++ cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; + cty_concr = concr_meths; + cty_inher = inher} in + let methods = get_methods self_type in +@@ -628,7 +661,11 @@ + be modified after this point *) + Ctype.close_object self_type; + let mets = virtual_methods {sign with cty_self = self_type} in +- if mets <> [] then raise(Error(loc, Virtual_class(true, mets))); ++ let vals = ++ Vars.fold ++ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) ++ sign.cty_vars [] in ++ if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals))); + let self_methods = + List.fold_right + (fun (lab,kind,ty) rem -> +@@ -1135,9 +1172,14 @@ + in + + if cl.pci_virt = Concrete then begin +- match virtual_methods (Ctype.signature_of_class_type typ) with +- [] -> () +- | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets))) ++ let sign = Ctype.signature_of_class_type typ in ++ let mets = virtual_methods sign in ++ let vals = ++ Vars.fold ++ (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))); + end; + + (* Misc. *) +@@ -1400,10 +1442,10 @@ + Printtyp.report_unification_error ppf trace + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") +- | Method_type_mismatch (m, trace) -> ++ | Field_type_mismatch (k, m, trace) -> + Printtyp.report_unification_error ppf trace + (function ppf -> +- fprintf ppf "The method %s@ has type" m) ++ fprintf ppf "The %s %s@ has type" k m) + (function ppf -> + fprintf ppf "but is expected to have type") + | Structure_expected clty -> +@@ -1451,15 +1493,20 @@ + fprintf ppf "The expression \"new %s\" has type" c) + (function ppf -> + fprintf ppf "but is used with type") +- | Virtual_class (cl, mets) -> ++ | Virtual_class (cl, mets, vals) -> + let print_mets ppf mets = + List.iter (function met -> fprintf ppf "@ %s" met) mets in + let cl_mark = if cl then "" else " type" in ++ let missings = ++ match mets, vals with ++ [], _ -> "variables" ++ | _, [] -> "methods" ++ | _ -> "methods and variables" ++ in + fprintf ppf +- "@[This class%s should be virtual@ \ +- @[<2>The following methods are undefined :%a@] +- @]" +- cl_mark print_mets mets ++ "@[This class%s should be virtual.@ \ ++ @[<2>The following %s are undefined :%a@]@]" ++ cl_mark missings print_mets (mets @ vals) + | Parameter_arity_mismatch(lid, expected, provided) -> + fprintf ppf + "@[The class constructor %a@ expects %i type argument(s),@ \ +@@ -1532,3 +1579,10 @@ + fprintf ppf "This object is expected to have type") + (function ppf -> + fprintf ppf "but has actually type") ++ | Mutability_mismatch (lab, mut) -> ++ let mut1, mut2 = ++ if mut = Immutable then "mutable", "immutable" ++ else "immutable", "mutable" in ++ fprintf ppf ++ "@[The instance variable is %s,@ it cannot be redefined as %s@]" ++ mut1 mut2 +Index: typing/typeclass.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v +retrieving revision 1.18 +diff -u -r1.18 typeclass.mli +--- typing/typeclass.mli 1 Dec 2003 00:32:11 -0000 1.18 ++++ typing/typeclass.mli 5 Apr 2006 02:26:00 -0000 +@@ -49,7 +49,7 @@ + + type error = + Unconsistent_constraint of (type_expr * type_expr) list +- | Method_type_mismatch of string * (type_expr * type_expr) list ++ | Field_type_mismatch of string * string * (type_expr * type_expr) list + | Structure_expected of class_type + | Cannot_apply of class_type + | Apply_wrong_label of label +@@ -61,7 +61,7 @@ + | Unbound_class_type_2 of Longident.t + | Abbrev_type_clash of type_expr * type_expr * type_expr + | Constructor_type_mismatch of string * (type_expr * type_expr) list +- | Virtual_class of bool * string list ++ | Virtual_class of bool * string list * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of (type_expr * type_expr) list + | Bad_parameters of Ident.t * type_expr * type_expr +@@ -74,6 +74,7 @@ + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * (type_expr * type_expr) list + | Final_self_clash of (type_expr * type_expr) list ++ | Mutability_mismatch of string * mutable_flag + + exception Error of Location.t * error + +Index: typing/typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.178 +diff -u -r1.178 typecore.ml +--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178 ++++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000 +@@ -611,11 +611,11 @@ + List.for_all + (function + Cf_meth _ -> true +- | Cf_val (_,_,e) -> incr count; is_nonexpansive e ++ | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e + | Cf_init e -> is_nonexpansive e + | Cf_inher _ | Cf_let _ -> false) + fields && +- Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable) ++ Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) + vars true && + !count = 0 + | _ -> false +@@ -1356,7 +1356,7 @@ + (path_self, _) -> + let type_override (lab, snewval) = + begin try +- let (id, _, ty) = Vars.find lab !vars in ++ let (id, _, _, ty) = Vars.find lab !vars in + (Path.Pident id, type_expect env snewval (instance ty)) + with + Not_found -> +Index: typing/typecore.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v +retrieving revision 1.37 +diff -u -r1.37 typecore.mli +--- typing/typecore.mli 4 Mar 2005 14:51:31 -0000 1.37 ++++ typing/typecore.mli 5 Apr 2006 02:26:00 -0000 +@@ -38,7 +38,8 @@ + string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> + Typedtree.pattern * + (Ident.t * type_expr) Meths.t ref * +- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * ++ (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) ++ Vars.t ref * + Env.t * Env.t * Env.t + val type_expect: + ?in_function:(Location.t * type_expr) -> +Index: typing/typedtree.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v +retrieving revision 1.36 +diff -u -r1.36 typedtree.ml +--- typing/typedtree.ml 25 Nov 2003 09:20:43 -0000 1.36 ++++ typing/typedtree.ml 5 Apr 2006 02:26:00 -0000 +@@ -106,7 +106,7 @@ + + and class_field = + Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list +- | Cf_val of string * Ident.t * expression ++ | Cf_val of string * Ident.t * expression option * bool + | Cf_meth of string * expression + | Cf_let of rec_flag * (pattern * expression) list * + (Ident.t * expression) list +@@ -140,7 +140,8 @@ + | Tstr_recmodule of (Ident.t * module_expr) list + | Tstr_modtype of Ident.t * module_type + | Tstr_open of Path.t +- | Tstr_class of (Ident.t * int * string list * class_expr) list ++ | Tstr_class of ++ (Ident.t * int * string list * class_expr * virtual_flag) list + | Tstr_cltype of (Ident.t * cltype_declaration) list + | Tstr_include of module_expr * Ident.t list + +Index: typing/typedtree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v +retrieving revision 1.34 +diff -u -r1.34 typedtree.mli +--- typing/typedtree.mli 25 Nov 2003 09:20:43 -0000 1.34 ++++ typing/typedtree.mli 5 Apr 2006 02:26:00 -0000 +@@ -107,7 +107,8 @@ + and class_field = + Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list + (* Inherited instance variables and concrete methods *) +- | Cf_val of string * Ident.t * expression ++ | Cf_val of string * Ident.t * expression option * bool ++ (* None = virtual, true = override *) + | Cf_meth of string * expression + | Cf_let of rec_flag * (pattern * expression) list * + (Ident.t * expression) list +@@ -141,7 +142,8 @@ + | Tstr_recmodule of (Ident.t * module_expr) list + | Tstr_modtype of Ident.t * module_type + | Tstr_open of Path.t +- | Tstr_class of (Ident.t * int * string list * class_expr) list ++ | Tstr_class of ++ (Ident.t * int * string list * class_expr * virtual_flag) list + | Tstr_cltype of (Ident.t * cltype_declaration) list + | Tstr_include of module_expr * Ident.t list + +Index: typing/typemod.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v +retrieving revision 1.73 +diff -u -r1.73 typemod.ml +--- typing/typemod.ml 8 Aug 2005 09:41:51 -0000 1.73 ++++ typing/typemod.ml 5 Apr 2006 02:26:00 -0000 +@@ -17,6 +17,7 @@ + open Misc + open Longident + open Path ++open Asttypes + open Parsetree + open Types + open Typedtree +@@ -667,8 +668,9 @@ + let (classes, new_env) = Typeclass.class_declarations env cl in + let (str_rem, sig_rem, final_env) = type_struct new_env srem in + (Tstr_class +- (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) -> +- (i, s, m, c)) classes) :: ++ (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)) classes) :: + Tstr_cltype + (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) :: + Tstr_type +Index: typing/types.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v +retrieving revision 1.25 +diff -u -r1.25 types.ml +--- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25 ++++ typing/types.ml 5 Apr 2006 02:26:00 -0000 +@@ -90,7 +90,8 @@ + | Val_prim of Primitive.description (* Primitive *) + | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) + | Val_self of (Ident.t * type_expr) Meths.t ref * +- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * ++ (Ident.t * Asttypes.mutable_flag * ++ Asttypes.virtual_flag * type_expr) Vars.t ref * + string * type_expr + (* Self *) + | Val_anc of (string * Ident.t) list * string +@@ -156,7 +157,8 @@ + + and class_signature = + { cty_self: type_expr; +- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t; ++ cty_vars: ++ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; + cty_concr: Concr.t; + cty_inher: (Path.t * type_expr list) list } + +Index: typing/types.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v +retrieving revision 1.25 +diff -u -r1.25 types.mli +--- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25 ++++ typing/types.mli 5 Apr 2006 02:26:00 -0000 +@@ -91,7 +91,8 @@ + | Val_prim of Primitive.description (* Primitive *) + | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) + | Val_self of (Ident.t * type_expr) Meths.t ref * +- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * ++ (Ident.t * Asttypes.mutable_flag * ++ Asttypes.virtual_flag * type_expr) Vars.t ref * + string * type_expr + (* Self *) + | Val_anc of (string * Ident.t) list * string +@@ -158,7 +159,8 @@ + + and class_signature = + { cty_self: type_expr; +- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t; ++ cty_vars: ++ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; + cty_concr: Concr.t; + cty_inher: (Path.t * type_expr list) list } + +Index: typing/unused_var.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v +retrieving revision 1.5 +diff -u -r1.5 unused_var.ml +--- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5 ++++ typing/unused_var.ml 5 Apr 2006 02:26:00 -0000 +@@ -245,7 +245,7 @@ + match cf with + | Pcf_inher (ce, _) -> class_expr ppf tbl ce; + | Pcf_val (_, _, e, _) -> expression ppf tbl e; +- | Pcf_virt _ -> () ++ | Pcf_virt _ | Pcf_valvirt _ -> () + | Pcf_meth (_, _, e, _) -> expression ppf tbl e; + | Pcf_cstr _ -> () + | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None; +Index: bytecomp/translclass.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v +retrieving revision 1.38 +diff -u -r1.38 translclass.ml +--- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38 ++++ bytecomp/translclass.ml 5 Apr 2006 02:26:00 -0000 +@@ -133,10 +133,10 @@ + (fun _ -> lambda_unit) cl + in + (inh_init, lsequence obj_init' obj_init, true) +- | Cf_val (_, id, exp) -> ++ | Cf_val (_, id, Some exp, _) -> + (inh_init, lsequence (set_inst_var obj id exp) obj_init, + has_init) +- | Cf_meth _ -> ++ | Cf_meth _ | Cf_val _ -> + (inh_init, obj_init, has_init) + | Cf_init _ -> + (inh_init, obj_init, true) +@@ -213,27 +213,17 @@ + if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else + let ids = Ident.create "ids" in +- let i = ref len in +- let getter, names, cl_init = +- match vals with [] -> "get_method_labels", [], cl_init +- | (_,id0)::vals' -> +- incr i; +- let i = ref (List.length vals) in +- "new_methods_variables", +- [transl_meth_list (List.map fst vals)], +- Llet(Strict, id0, lfield ids 0, +- List.fold_right +- (fun (name,id) rem -> +- decr i; +- Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem)) +- vals' cl_init) ++ let i = ref (len + nvals) in ++ let getter, names = ++ if nvals = 0 then "get_method_labels", [] else ++ "new_methods_variables", [transl_meth_list (List.map fst vals)] + in + Llet(StrictOpt, ids, + Lapply (oo_prim getter, + [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), + List.fold_right + (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) +- methl cl_init) ++ (methl @ vals) cl_init) + + let output_methods tbl methods lam = + match methods with +@@ -283,8 +273,9 @@ + (vals, meths_super cla str.cl_meths meths) + inh_init cl_init msubst top cl in + (inh_init, cl_init, [], values) +- | Cf_val (name, id, exp) -> +- (inh_init, cl_init, methods, (name, id)::values) ++ | Cf_val (name, id, exp, over) -> ++ let values = if over then values else (name, id) :: values in ++ (inh_init, cl_init, methods, values) + | Cf_meth (name, exp) -> + let met_code = msubst true (transl_exp exp) in + let met_code = +@@ -342,27 +333,24 @@ + assert (Path.same path path'); + let lpath = transl_path path in + let inh = Ident.create "inh" +- and inh_vals = Ident.create "vals" +- and inh_meths = Ident.create "meths" ++ and ofs = List.length vals + 1 + and valids, methids = super in + let cl_init = + List.fold_left + (fun init (nm, id, _) -> +- Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths), ++ Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs), + init)) + cl_init methids in + let cl_init = + List.fold_left + (fun init (nm, id) -> +- Llet(StrictOpt, id, lfield inh_vals (index nm vals), init)) ++ Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)) + cl_init valids in + (inh_init, + Llet (Strict, inh, + Lapply(oo_prim "inherits", narrow_args @ + [lpath; Lconst(Const_pointer(if top then 1 else 0))]), +- Llet(StrictOpt, obj_init, lfield inh 0, +- Llet(Alias, inh_vals, lfield inh 1, +- Llet(Alias, inh_meths, lfield inh 2, cl_init))))) ++ Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) + | _ -> + let core cl_init = + build_class_init cla true super inh_init cl_init msubst top cl +@@ -397,12 +385,16 @@ + XXX Il devrait etre peu couteux d'ecrire des classes : + class c x y = d e f + *) +-let rec transl_class_rebind obj_init cl = ++let rec transl_class_rebind obj_init cl vf = + match cl.cl_desc with + Tclass_ident path -> ++ if vf = Concrete then begin ++ try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit ++ with Not_found -> raise Exit ++ end; + (path, obj_init) + | Tclass_fun (pat, _, cl, partial) -> +- let path, obj_init = transl_class_rebind obj_init cl in ++ let path, obj_init = transl_class_rebind obj_init cl vf in + let build params rem = + let param = name_pattern "param" [pat, ()] in + Lfunction (Curried, param::params, +@@ -414,14 +406,14 @@ + Lfunction (Curried, params, rem) -> build params rem + | rem -> build [] rem) + | Tclass_apply (cl, oexprs) -> +- let path, obj_init = transl_class_rebind obj_init cl in ++ let path, obj_init = transl_class_rebind obj_init cl vf in + (path, transl_apply obj_init oexprs) + | Tclass_let (rec_flag, defs, vals, cl) -> +- let path, obj_init = transl_class_rebind obj_init cl in ++ let path, obj_init = transl_class_rebind obj_init cl vf in + (path, Translcore.transl_let rec_flag defs obj_init) + | Tclass_structure _ -> raise Exit + | Tclass_constraint (cl', _, _, _) -> +- let path, obj_init = transl_class_rebind obj_init cl' in ++ let path, obj_init = transl_class_rebind obj_init cl' vf in + let rec check_constraint = function + Tcty_constr(path', _, _) when Path.same path path' -> () + | Tcty_fun (_, _, cty) -> check_constraint cty +@@ -430,21 +422,21 @@ + check_constraint cl.cl_type; + (path, obj_init) + +-let rec transl_class_rebind_0 self obj_init cl = ++let rec transl_class_rebind_0 self obj_init cl vf = + match cl.cl_desc with + Tclass_let (rec_flag, defs, vals, cl) -> +- let path, obj_init = transl_class_rebind_0 self obj_init cl in ++ let path, obj_init = transl_class_rebind_0 self obj_init cl vf in + (path, Translcore.transl_let rec_flag defs obj_init) + | _ -> +- let path, obj_init = transl_class_rebind obj_init cl in ++ let path, obj_init = transl_class_rebind obj_init cl vf in + (path, lfunction [self] obj_init) + +-let transl_class_rebind ids cl = ++let transl_class_rebind ids cl vf = + try + let obj_init = Ident.create "obj_init" + and self = Ident.create "self" in + let obj_init0 = lapply (Lvar obj_init) [Lvar self] in +- let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in ++ let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in + if not (Translcore.check_recursive_lambda ids obj_init') then + raise(Error(cl.cl_loc, Illegal_class_expr)); + let id = (obj_init' = lfunction [self] obj_init0) in +@@ -592,9 +584,9 @@ + *) + + +-let transl_class ids cl_id arity pub_meths cl = ++let transl_class ids cl_id arity pub_meths cl vflag = + (* First check if it is not only a rebind *) +- let rebind = transl_class_rebind ids cl in ++ let rebind = transl_class_rebind ids cl vflag in + if rebind <> lambda_unit then rebind else + + (* Prepare for heavy environment handling *) +@@ -696,9 +688,7 @@ + (* Simplest case: an object defined at toplevel (ids=[]) *) + if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + +- let concrete = +- ids = [] || +- Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = [] ++ let concrete = (vflag = Concrete) + and lclass lam = + let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in + Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) +@@ -800,11 +790,11 @@ + + (* Wrapper for class compilation *) + +-let transl_class ids cl_id arity pub_meths cl = +- oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl ++let transl_class ids cl_id arity pub_meths cl vf = ++ oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf + + let () = +- transl_object := (fun id meths cl -> transl_class [] id 0 meths cl) ++ transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete) + + (* Error report *) + +Index: bytecomp/translclass.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v +retrieving revision 1.11 +diff -u -r1.11 translclass.mli +--- bytecomp/translclass.mli 12 Aug 2004 12:55:11 -0000 1.11 ++++ bytecomp/translclass.mli 5 Apr 2006 02:26:00 -0000 +@@ -16,7 +16,8 @@ + open Lambda + + val transl_class : +- Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;; ++ Ident.t list -> Ident.t -> ++ int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;; + + type error = Illegal_class_expr | Tags of string * string + +Index: bytecomp/translmod.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v +retrieving revision 1.51 +diff -u -r1.51 translmod.ml +--- bytecomp/translmod.ml 12 Aug 2004 12:55:11 -0000 1.51 ++++ bytecomp/translmod.ml 5 Apr 2006 02:26:00 -0000 +@@ -317,10 +317,10 @@ + | Tstr_open path :: rem -> + transl_structure fields cc rootpath rem + | Tstr_class cl_list :: rem -> +- let ids = List.map (fun (i, _, _, _) -> i) cl_list in ++ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in + Lletrec(List.map +- (fun (id, arity, meths, cl) -> +- (id, transl_class ids id arity meths cl)) ++ (fun (id, arity, meths, cl, vf) -> ++ (id, transl_class ids id arity meths cl vf)) + cl_list, + transl_structure (List.rev ids @ fields) cc rootpath rem) + | Tstr_cltype cl_list :: rem -> +@@ -414,11 +414,11 @@ + | Tstr_open path :: rem -> + transl_store subst rem + | Tstr_class cl_list :: rem -> +- let ids = List.map (fun (i, _, _, _) -> i) cl_list in ++ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in + let lam = + Lletrec(List.map +- (fun (id, arity, meths, cl) -> +- (id, transl_class ids id arity meths cl)) ++ (fun (id, arity, meths, cl, vf) -> ++ (id, transl_class ids id arity meths cl vf)) + cl_list, + store_idents ids) in + Lsequence(subst_lambda subst lam, +@@ -485,7 +485,7 @@ + | Tstr_modtype(id, decl) :: rem -> defined_idents rem + | Tstr_open path :: rem -> defined_idents rem + | Tstr_class cl_list :: rem -> +- List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem ++ List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem + | Tstr_cltype cl_list :: rem -> defined_idents rem + | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem + +@@ -603,14 +603,14 @@ + | Tstr_class cl_list -> + (* we need to use unique names for the classes because there might + be a value named identically *) +- let ids = List.map (fun (i, _, _, _) -> i) cl_list in ++ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in + List.iter set_toplevel_unique_name ids; + Lletrec(List.map +- (fun (id, arity, meths, cl) -> +- (id, transl_class ids id arity meths cl)) ++ (fun (id, arity, meths, cl, vf) -> ++ (id, transl_class ids id arity meths cl vf)) + cl_list, + make_sequence +- (fun (id, _, _, _) -> toploop_setvalue_id id) ++ (fun (id, _, _, _, _) -> toploop_setvalue_id id) + cl_list) + | Tstr_cltype cl_list -> + lambda_unit +Index: driver/main_args.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v +retrieving revision 1.48 +diff -u -r1.48 main_args.ml +--- driver/main_args.ml 4 Jan 2006 16:55:49 -0000 1.48 ++++ driver/main_args.ml 5 Apr 2006 02:26:00 -0000 +@@ -136,11 +136,11 @@ + \032 E/e enable/disable fragile match\n\ + \032 F/f enable/disable partially applied function\n\ + \032 L/l enable/disable labels omitted in application\n\ +- \032 M/m enable/disable overridden method\n\ ++ \032 M/m enable/disable overridden methods\n\ + \032 P/p enable/disable partial match\n\ + \032 S/s enable/disable non-unit statement\n\ + \032 U/u enable/disable unused match case\n\ +- \032 V/v enable/disable hidden instance variable\n\ ++ \032 V/v enable/disable overridden instance variables\n\ + \032 Y/y enable/disable suspicious unused variables\n\ + \032 Z/z enable/disable all other unused variables\n\ + \032 X/x enable/disable all other warnings\n\ +Index: driver/optmain.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v +retrieving revision 1.87 +diff -u -r1.87 optmain.ml +--- driver/optmain.ml 4 Jan 2006 16:55:49 -0000 1.87 ++++ driver/optmain.ml 5 Apr 2006 02:26:00 -0000 +@@ -173,7 +173,7 @@ + \032 P/p enable/disable partial match\n\ + \032 S/s enable/disable non-unit statement\n\ + \032 U/u enable/disable unused match case\n\ +- \032 V/v enable/disable hidden instance variables\n\ ++ \032 V/v enable/disable overridden instance variables\n\ + \032 Y/y enable/disable suspicious unused variables\n\ + \032 Z/z enable/disable all other unused variables\n\ + \032 X/x enable/disable all other warnings\n\ +Index: stdlib/camlinternalOO.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v +retrieving revision 1.14 +diff -u -r1.14 camlinternalOO.ml +--- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14 ++++ stdlib/camlinternalOO.ml 5 Apr 2006 02:26:00 -0000 +@@ -206,7 +206,11 @@ + (table.methods_by_name, table.methods_by_label, table.hidden_meths, + table.vars, virt_meth_labs, vars) + :: table.previous_states; +- table.vars <- Vars.empty; ++ table.vars <- ++ Vars.fold ++ (fun lab info tvars -> ++ if List.mem lab vars then Vars.add lab info tvars else tvars) ++ table.vars Vars.empty; + let by_name = ref Meths.empty in + let by_label = ref Labs.empty in + List.iter2 +@@ -255,9 +259,11 @@ + index + + let new_variable table name = +- let index = new_slot table in +- table.vars <- Vars.add name index table.vars; +- index ++ try Vars.find name table.vars ++ with Not_found -> ++ let index = new_slot table in ++ table.vars <- Vars.add name index table.vars; ++ index + + let to_array arr = + if arr = Obj.magic 0 then [||] else arr +@@ -265,16 +271,17 @@ + let new_methods_variables table meths vals = + let meths = to_array meths in + let nmeths = Array.length meths and nvals = Array.length vals in +- let index = new_variable table vals.(0) in +- let res = Array.create (nmeths + 1) index in +- for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done; ++ let res = Array.create (nmeths + nvals) 0 in + for i = 0 to nmeths - 1 do +- res.(i+1) <- get_method_label table meths.(i) ++ res.(i) <- get_method_label table meths.(i) ++ done; ++ for i = 0 to nvals - 1 do ++ res.(i+nmeths) <- new_variable table vals.(i) + done; + res + + let get_variable table name = +- Vars.find name table.vars ++ try Vars.find name table.vars with Not_found -> assert false + + let get_variables table names = + Array.map (get_variable table) names +@@ -315,9 +322,12 @@ + let init = + if top then super cla env else Obj.repr (super cla) in + widen cla; +- (init, Array.map (get_variable cla) (to_array vals), +- Array.map (fun nm -> get_method cla (get_method_label cla nm)) +- (to_array concr_meths)) ++ Array.concat ++ [[| repr init |]; ++ magic (Array.map (get_variable cla) (to_array vals) : int array); ++ Array.map ++ (fun nm -> repr (get_method cla (get_method_label cla nm) : closure)) ++ (to_array concr_meths) ] + + let make_class pub_meths class_init = + let table = create_table pub_meths in +Index: stdlib/camlinternalOO.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v +retrieving revision 1.9 +diff -u -r1.9 camlinternalOO.mli +--- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9 ++++ stdlib/camlinternalOO.mli 5 Apr 2006 02:26:00 -0000 +@@ -46,8 +46,7 @@ + val init_class : table -> unit + val inherits : + table -> string array -> string array -> string array -> +- (t * (table -> obj -> Obj.t) * t * obj) -> bool -> +- (Obj.t * int array * closure array) ++ (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array + val make_class : + string array -> (table -> Obj.t -> t) -> + (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) +@@ -79,6 +78,7 @@ + + (** {6 Builtins to reduce code size} *) + ++(* + val get_const : t -> closure + val get_var : int -> closure + val get_env : int -> int -> closure +@@ -103,6 +103,7 @@ + val send_var : tag -> int -> int -> closure + val send_env : tag -> int -> int -> int -> closure + val send_meth : tag -> label -> int -> closure ++*) + + type impl = + GetConst +Index: stdlib/sys.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v +retrieving revision 1.142 +diff -u -r1.142 sys.ml +--- stdlib/sys.ml 22 Mar 2006 12:39:39 -0000 1.142 ++++ stdlib/sys.ml 5 Apr 2006 02:26:00 -0000 +@@ -78,4 +78,4 @@ + + (* OCaml version string, must be in the format described in sys.mli. *) + +-let ocaml_version = "3.10+dev4 (2006-03-22)";; ++let ocaml_version = "3.10+dev5 (2006-04-05)";; +Index: tools/depend.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v +retrieving revision 1.9 +diff -u -r1.9 depend.ml +--- tools/depend.ml 23 Mar 2005 03:08:37 -0000 1.9 ++++ tools/depend.ml 5 Apr 2006 02:26:00 -0000 +@@ -87,7 +87,7 @@ + + and add_class_type_field bv = function + Pctf_inher cty -> add_class_type bv cty +- | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty ++ | Pctf_val(_, _, _, ty, _) -> add_type bv ty + | Pctf_virt(_, _, ty, _) -> add_type bv ty + | Pctf_meth(_, _, ty, _) -> add_type bv ty + | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 +@@ -280,6 +280,7 @@ + and add_class_field bv = function + Pcf_inher(ce, _) -> add_class_expr bv ce + | Pcf_val(_, _, e, _) -> add_expr bv e ++ | Pcf_valvirt(_, _, ty, _) + | Pcf_virt(_, _, ty, _) -> add_type bv ty + | Pcf_meth(_, _, e, _) -> add_expr bv e + | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 +Index: tools/ocamlprof.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v +retrieving revision 1.38 +diff -u -r1.38 ocamlprof.ml +--- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000 1.38 ++++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000 +@@ -328,7 +328,7 @@ + rewrite_patexp_list iflag spat_sexp_list + | Pcf_init sexp -> + rewrite_exp iflag sexp +- | Pcf_virt _ | Pcf_cstr _ -> () ++ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () + + and rewrite_class_expr iflag cexpr = + match cexpr.pcl_desc with +Index: otherlibs/labltk/browser/searchpos.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v +retrieving revision 1.48 +diff -u -r1.48 searchpos.ml +--- otherlibs/labltk/browser/searchpos.ml 23 Mar 2005 03:08:37 -0000 1.48 ++++ otherlibs/labltk/browser/searchpos.ml 5 Apr 2006 02:26:01 -0000 +@@ -141,9 +141,8 @@ + List.iter cfl ~f: + begin function + Pctf_inher cty -> search_pos_class_type cty ~pos ~env +- | Pctf_val (_, _, Some ty, loc) -> ++ | Pctf_val (_, _, _, ty, loc) -> + if in_loc loc ~pos then search_pos_type ty ~pos ~env +- | Pctf_val _ -> () + | Pctf_virt (_, _, ty, loc) -> + if in_loc loc ~pos then search_pos_type ty ~pos ~env + | Pctf_meth (_, _, ty, loc) -> +@@ -675,7 +674,7 @@ + | Tstr_modtype _ -> () + | Tstr_open _ -> () + | Tstr_class l -> +- List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos) ++ List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos) + | Tstr_cltype _ -> () + | Tstr_include (m, _) -> search_pos_module_expr m ~pos + end +@@ -685,7 +684,8 @@ + begin function + Cf_inher (cl, _, _) -> + search_pos_class_expr cl ~pos +- | Cf_val (_, _, exp) -> search_pos_expr exp ~pos ++ | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos ++ | Cf_val _ -> () + | Cf_meth (_, exp) -> search_pos_expr exp ~pos + | Cf_let (_, pel, iel) -> + List.iter pel ~f: +Index: ocamldoc/Makefile +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v +retrieving revision 1.61 +diff -u -r1.61 Makefile +--- ocamldoc/Makefile 4 Jan 2006 16:55:49 -0000 1.61 ++++ ocamldoc/Makefile 5 Apr 2006 02:26:01 -0000 +@@ -31,7 +31,7 @@ + MKDIR=mkdir -p + CP=cp -f + OCAMLDOC=ocamldoc +-OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) ++OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) + OCAMLDOC_OPT=$(OCAMLDOC).opt + OCAMLDOC_LIBCMA=odoc_info.cma + OCAMLDOC_LIBCMI=odoc_info.cmi +@@ -188,12 +188,12 @@ + ../otherlibs/num/num.mli + + all: exe lib +- $(MAKE) manpages + + exe: $(OCAMLDOC) + lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) + + opt.opt: exeopt libopt ++ $(MAKE) manpages + exeopt: $(OCAMLDOC_OPT) + libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) + debug: +Index: ocamldoc/odoc_ast.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v +retrieving revision 1.27 +diff -u -r1.27 odoc_ast.ml +--- ocamldoc/odoc_ast.ml 4 Jan 2006 16:55:49 -0000 1.27 ++++ ocamldoc/odoc_ast.ml 5 Apr 2006 02:26:01 -0000 +@@ -88,7 +88,7 @@ + ident_type_decl_list + | Typedtree.Tstr_class info_list -> + List.iter +- (fun ((id,_,_,_) as ci) -> ++ (fun ((id,_,_,_,_) as ci) -> + Hashtbl.add table (C (Name.from_ident id)) + (Typedtree.Tstr_class [ci])) + info_list +@@ -146,7 +146,7 @@ + + let search_class_exp table name = + match Hashtbl.find table (C name) with +- | (Typedtree.Tstr_class [(_,_,_,ce)]) -> ++ | (Typedtree.Tstr_class [(_,_,_,ce,_)]) -> + ( + try + let type_decl = search_type_declaration table name in +@@ -184,7 +184,7 @@ + let rec iter = function + | [] -> + raise Not_found +- | Typedtree.Cf_val (_, ident, exp) :: q ++ | Typedtree.Cf_val (_, ident, Some exp, _) :: q + when Name.from_ident ident = name -> + exp.Typedtree.exp_type + | _ :: q -> +@@ -523,7 +523,8 @@ + p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum + q + +- | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q -> ++ | (Parsetree.Pcf_val (label, mutable_flag, _, loc) | ++ Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q -> + 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 = +Index: ocamldoc/odoc_sig.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v +retrieving revision 1.37 +diff -u -r1.37 odoc_sig.ml +--- ocamldoc/odoc_sig.ml 4 Jan 2006 16:55:50 -0000 1.37 ++++ ocamldoc/odoc_sig.ml 5 Apr 2006 02:26:01 -0000 +@@ -107,7 +107,7 @@ + | _ -> assert false + + let search_attribute_type name class_sig = +- let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in ++ let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in + type_expr + + let search_method_type name class_sig = +@@ -269,7 +269,7 @@ + [] -> pos_limit + | ele2 :: _ -> + match ele2 with +- Parsetree.Pctf_val (_, _, _, loc) ++ Parsetree.Pctf_val (_, _, _, _, loc) + | Parsetree.Pctf_virt (_, _, _, loc) + | Parsetree.Pctf_meth (_, _, _, loc) + | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum +@@ -330,7 +330,7 @@ + in + ([], ele_comments) + +- | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q -> ++ | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q -> + (* of (string * mutable_flag * core_type option * Location.t)*) + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let complete_name = Name.concat current_class_name name in +Index: camlp4/camlp4/ast2pt.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v +retrieving revision 1.36 +diff -u -r1.36 ast2pt.ml +--- camlp4/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36 ++++ camlp4/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000 +@@ -244,6 +244,7 @@ + ; + value mkmutable m = if m then Mutable else Immutable; + value mkprivate m = if m then Private else Public; ++value mkvirtual m = if m then Virtual else Concrete; + value mktrecord (loc, n, m, t) = + (n, mkmutable m, ctyp (mkpolytype t), mkloc loc); + value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc); +@@ -862,8 +863,8 @@ + | CgInh loc ct -> [Pctf_inher (class_type ct) :: l] + | CgMth loc s pf t -> + [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l] +- | CgVal loc s b t -> +- [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l] ++ | CgVal loc s b v t -> ++ [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l] + | CgVir loc s b t -> + [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] + and class_expr = +@@ -907,7 +908,9 @@ + [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l] + | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] + | CrVir loc s b t -> +- [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] ++ [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ++ | CrVvr loc s b t -> ++ [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ] + ; + + value interf ast = List.fold_right sig_item ast []; +Index: camlp4/camlp4/mLast.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v +retrieving revision 1.18 +diff -u -r1.18 mLast.mli +--- camlp4/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.18 ++++ camlp4/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000 +@@ -180,7 +180,7 @@ + | CgDcl of loc and list class_sig_item + | CgInh of loc and class_type + | CgMth of loc and string and bool and ctyp +- | CgVal of loc and string and bool and ctyp ++ | CgVal of loc and string and bool and bool and ctyp + | CgVir of loc and string and bool and ctyp ] + and class_expr = + [ CeApp of loc and class_expr and expr +@@ -196,7 +196,8 @@ + | CrIni of loc and expr + | CrMth of loc and string and bool and expr and option ctyp + | CrVal of loc and string and bool and expr +- | CrVir of loc and string and bool and ctyp ] ++ | CrVir of loc and string and bool and ctyp ++ | CrVvr of loc and string and bool and ctyp ] + ; + + external loc_of_ctyp : ctyp -> loc = "%field0"; +Index: camlp4/camlp4/reloc.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v +retrieving revision 1.18 +diff -u -r1.18 reloc.ml +--- camlp4/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.18 ++++ camlp4/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000 +@@ -350,7 +350,7 @@ + | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1) + | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1) + | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3) +- | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3) ++ | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4) + | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ] + and class_expr floc sh = + self where rec self = +@@ -377,5 +377,6 @@ + | CrMth loc x1 x2 x3 x4 -> + let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4) + | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3) +- | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ] ++ | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ++ | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ] + ; +Index: camlp4/etc/pa_o.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v +retrieving revision 1.66 +diff -u -r1.66 pa_o.ml +--- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000 1.66 ++++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000 +@@ -1037,8 +1037,14 @@ + class_str_item: + [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> + <:class_str_item< inherit $ce$ $opt:pb$ >> +- | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> +- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> ++ | "val"; "mutable"; lab = label; e = cvalue_binding -> ++ <:class_str_item< value mutable $lab$ = $e$ >> ++ | "val"; lab = label; e = cvalue_binding -> ++ <:class_str_item< value $lab$ = $e$ >> ++ | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp -> ++ <:class_str_item< value virtual mutable $lab$ : $t$ >> ++ | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp -> ++ <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >> + | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> + <:class_str_item< method virtual private $l$ : $t$ >> + | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> +@@ -1087,8 +1093,9 @@ + ; + class_sig_item: + [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> +- | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> +- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> ++ | "val"; mf = OPT "mutable"; vf = OPT "virtual"; ++ l = label; ":"; t = ctyp -> ++ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >> + | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> + <:class_sig_item< method virtual private $l$ : $t$ >> + | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> +Index: camlp4/etc/pr_o.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v +retrieving revision 1.51 +diff -u -r1.51 pr_o.ml +--- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000 1.51 ++++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000 +@@ -1768,10 +1768,11 @@ + [: `S LR "method"; private_flag pf; `label lab; + `S LR ":" :]; + `ctyp t "" k :] +- | MLast.CgVal _ lab mf t -> ++ | MLast.CgVal _ lab mf vf t -> + fun curr next dg k -> + [: `HVbox +- [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; ++ [: `S LR "val"; mutable_flag mf; virtual_flag vf; ++ `label lab; `S LR ":" :]; + `ctyp t "" k :] + | MLast.CgVir _ lab pf t -> + fun curr next dg k -> +Index: camlp4/meta/pa_r.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v +retrieving revision 1.64 +diff -u -r1.64 pa_r.ml +--- camlp4/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.64 ++++ camlp4/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000 +@@ -658,7 +658,9 @@ + | "inherit"; ce = class_expr; pb = OPT as_lident -> + <:class_str_item< inherit $ce$ $opt:pb$ >> + | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> +- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> ++ <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> ++ | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> ++ <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >> + | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> + <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >> + | "method"; pf = OPT "private"; l = label; topt = OPT polyt; +@@ -701,8 +703,9 @@ + [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" -> + <:class_sig_item< declare $list:st$ end >> + | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >> +- | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> +- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> ++ | "value"; mf = OPT "mutable"; vf = OPT "virtual"; ++ l = label; ":"; t = ctyp -> ++ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >> + | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> + <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >> + | "method"; pf = OPT "private"; l = label; ":"; t = ctyp -> +Index: camlp4/meta/q_MLast.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v +retrieving revision 1.60 +diff -u -r1.60 q_MLast.ml +--- camlp4/meta/q_MLast.ml 29 Jun 2005 04:11:26 -0000 1.60 ++++ camlp4/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000 +@@ -947,6 +947,8 @@ + Qast.Node "CrDcl" [Qast.Loc; st] + | "inherit"; ce = class_expr; pb = SOPT as_lident -> + Qast.Node "CrInh" [Qast.Loc; ce; pb] ++ | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> ++ Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t] + | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding -> + Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e] + | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> +@@ -992,8 +994,9 @@ + [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" -> + Qast.Node "CgDcl" [Qast.Loc; st] + | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs] +- | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> +- Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t] ++ | "value"; mf = SOPT "mutable"; vf = SOPT "virtual"; ++ l = label; ":"; t = ctyp -> ++ Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t] + | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> + Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t] + | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp -> +Index: camlp4/ocaml_src/camlp4/ast2pt.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v +retrieving revision 1.36 +diff -u -r1.36 ast2pt.ml +--- camlp4/ocaml_src/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36 ++++ camlp4/ocaml_src/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000 +@@ -227,6 +227,7 @@ + ;; + let mkmutable m = if m then Mutable else Immutable;; + let mkprivate m = if m then Private else Public;; ++let mkvirtual m = if m then Virtual else Concrete;; + let mktrecord (loc, n, m, t) = + n, mkmutable m, ctyp (mkpolytype t), mkloc loc + ;; +@@ -878,8 +879,8 @@ + | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l + | CgMth (loc, s, pf, t) -> + Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l +- | CgVal (loc, s, b, t) -> +- Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l ++ | CgVal (loc, s, b, v, t) -> ++ Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l + | CgVir (loc, s, b, t) -> + Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l + and class_expr = +@@ -923,6 +924,8 @@ + | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l + | CrVir (loc, s, b, t) -> + Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l ++ | CrVvr (loc, s, b, t) -> ++ Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l + ;; + + let interf ast = List.fold_right sig_item ast [];; +Index: camlp4/ocaml_src/camlp4/mLast.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v +retrieving revision 1.20 +diff -u -r1.20 mLast.mli +--- camlp4/ocaml_src/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.20 ++++ camlp4/ocaml_src/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000 +@@ -180,7 +180,7 @@ + | CgDcl of loc * class_sig_item list + | CgInh of loc * class_type + | CgMth of loc * string * bool * ctyp +- | CgVal of loc * string * bool * ctyp ++ | CgVal of loc * string * bool * bool * ctyp + | CgVir of loc * string * bool * ctyp + and class_expr = + CeApp of loc * class_expr * expr +@@ -197,6 +197,7 @@ + | CrMth of loc * string * bool * expr * ctyp option + | CrVal of loc * string * bool * expr + | CrVir of loc * string * bool * ctyp ++ | CrVvr of loc * string * bool * ctyp + ;; + + external loc_of_ctyp : ctyp -> loc = "%field0";; +Index: camlp4/ocaml_src/camlp4/reloc.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v +retrieving revision 1.20 +diff -u -r1.20 reloc.ml +--- camlp4/ocaml_src/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.20 ++++ camlp4/ocaml_src/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000 +@@ -430,8 +430,8 @@ + let nloc = floc loc in CgInh (nloc, class_type floc sh x1) + | CgMth (loc, x1, x2, x3) -> + let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3) +- | CgVal (loc, x1, x2, x3) -> +- let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3) ++ | CgVal (loc, x1, x2, x3, x4) -> ++ let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4) + | CgVir (loc, x1, x2, x3) -> + let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3) + in +@@ -478,6 +478,8 @@ + let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3) + | CrVir (loc, x1, x2, x3) -> + let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3) ++ | CrVvr (loc, x1, x2, x3) -> ++ let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3) + in + self + ;; +Index: camlp4/ocaml_src/meta/pa_r.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v +retrieving revision 1.59 +diff -u -r1.59 pa_r.ml +--- camlp4/ocaml_src/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.59 ++++ camlp4/ocaml_src/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000 +@@ -2161,6 +2161,15 @@ + (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ + (_loc : Lexing.position * Lexing.position) -> + (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item)); ++ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual"); ++ Gramext.Sopt (Gramext.Stoken ("", "mutable")); ++ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); ++ Gramext.Stoken ("", ":"); ++ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], ++ Gramext.action ++ (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _ ++ (_loc : Lexing.position * Lexing.position) -> ++ (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item)); + [Gramext.Stoken ("", "value"); + Gramext.Sopt (Gramext.Stoken ("", "mutable")); + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); +@@ -2338,13 +2347,15 @@ + (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item)); + [Gramext.Stoken ("", "value"); + Gramext.Sopt (Gramext.Stoken ("", "mutable")); ++ Gramext.Sopt (Gramext.Stoken ("", "virtual")); + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action +- (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ ++ (fun (t : 'ctyp) _ (l : 'label) (vf : string option) ++ (mf : string option) _ + (_loc : Lexing.position * Lexing.position) -> +- (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item)); ++ (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item)); + [Gramext.Stoken ("", "inherit"); + Gramext.Snterm + (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], +Index: camlp4/ocaml_src/meta/q_MLast.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v +retrieving revision 1.65 +diff -u -r1.65 q_MLast.ml +--- camlp4/ocaml_src/meta/q_MLast.ml 12 Jan 2006 08:54:21 -0000 1.65 ++++ camlp4/ocaml_src/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000 +@@ -3152,9 +3152,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__17))])], ++ (Qast.Str x : 'e__18))])], + Gramext.action +- (fun (a : 'e__17 option) ++ (fun (a : 'e__18 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3191,9 +3191,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__16))])], ++ (Qast.Str x : 'e__17))])], + Gramext.action +- (fun (a : 'e__16 option) ++ (fun (a : 'e__17 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3216,9 +3216,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__15))])], ++ (Qast.Str x : 'e__16))])], + Gramext.action +- (fun (a : 'e__15 option) ++ (fun (a : 'e__16 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3235,6 +3235,31 @@ + (_loc : Lexing.position * Lexing.position) -> + (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : + 'class_str_item)); ++ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual"); ++ Gramext.srules ++ [[Gramext.Sopt ++ (Gramext.srules ++ [[Gramext.Stoken ("", "mutable")], ++ Gramext.action ++ (fun (x : string) ++ (_loc : Lexing.position * Lexing.position) -> ++ (Qast.Str x : 'e__15))])], ++ Gramext.action ++ (fun (a : 'e__15 option) ++ (_loc : Lexing.position * Lexing.position) -> ++ (Qast.Option a : 'a_opt)); ++ [Gramext.Snterm ++ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], ++ Gramext.action ++ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> ++ (a : 'a_opt))]; ++ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); ++ Gramext.Stoken ("", ":"); ++ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], ++ Gramext.action ++ (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _ ++ (_loc : Lexing.position * Lexing.position) -> ++ (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item)); + [Gramext.Stoken ("", "inherit"); + Gramext.Snterm + (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); +@@ -3366,9 +3391,9 @@ + Gramext.action + (fun _ (csf : 'class_sig_item) + (_loc : Lexing.position * Lexing.position) -> +- (csf : 'e__18))])], ++ (csf : 'e__19))])], + Gramext.action +- (fun (a : 'e__18 list) ++ (fun (a : 'e__19 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -3446,9 +3471,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__22))])], ++ (Qast.Str x : 'e__24))])], + Gramext.action +- (fun (a : 'e__22 option) ++ (fun (a : 'e__24 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3471,9 +3496,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__21))])], ++ (Qast.Str x : 'e__23))])], + Gramext.action +- (fun (a : 'e__21 option) ++ (fun (a : 'e__23 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3496,9 +3521,26 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__20))])], ++ (Qast.Str x : 'e__21))])], + Gramext.action +- (fun (a : 'e__20 option) ++ (fun (a : 'e__21 option) ++ (_loc : Lexing.position * Lexing.position) -> ++ (Qast.Option a : 'a_opt)); ++ [Gramext.Snterm ++ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], ++ Gramext.action ++ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> ++ (a : 'a_opt))]; ++ Gramext.srules ++ [[Gramext.Sopt ++ (Gramext.srules ++ [[Gramext.Stoken ("", "virtual")], ++ Gramext.action ++ (fun (x : string) ++ (_loc : Lexing.position * Lexing.position) -> ++ (Qast.Str x : 'e__22))])], ++ Gramext.action ++ (fun (a : 'e__22 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3510,9 +3552,10 @@ + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action +- (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ ++ (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _ + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item)); ++ (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) : ++ 'class_sig_item)); + [Gramext.Stoken ("", "inherit"); + Gramext.Snterm + (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], +@@ -3531,9 +3574,9 @@ + Gramext.action + (fun _ (s : 'class_sig_item) + (_loc : Lexing.position * Lexing.position) -> +- (s : 'e__19))])], ++ (s : 'e__20))])], + Gramext.action +- (fun (a : 'e__19 list) ++ (fun (a : 'e__20 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -3556,9 +3599,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__23))])], ++ (Qast.Str x : 'e__25))])], + Gramext.action +- (fun (a : 'e__23 option) ++ (fun (a : 'e__25 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3593,9 +3636,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__24))])], ++ (Qast.Str x : 'e__26))])], + Gramext.action +- (fun (a : 'e__24 option) ++ (fun (a : 'e__26 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3713,9 +3756,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__25))])], ++ (Qast.Str x : 'e__27))])], + Gramext.action +- (fun (a : 'e__25 option) ++ (fun (a : 'e__27 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -3922,9 +3965,9 @@ + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> +- (Qast.Str x : 'e__26))])], ++ (Qast.Str x : 'e__28))])], + Gramext.action +- (fun (a : 'e__26 option) ++ (fun (a : 'e__28 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm +@@ -4390,9 +4433,9 @@ + Gramext.action + (fun _ (e : 'expr) + (_loc : Lexing.position * Lexing.position) -> +- (e : 'e__29))])], ++ (e : 'e__31))])], + Gramext.action +- (fun (a : 'e__29 list) ++ (fun (a : 'e__31 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -4425,9 +4468,9 @@ + Gramext.action + (fun _ (e : 'expr) + (_loc : Lexing.position * Lexing.position) -> +- (e : 'e__28))])], ++ (e : 'e__30))])], + Gramext.action +- (fun (a : 'e__28 list) ++ (fun (a : 'e__30 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -4454,9 +4497,9 @@ + Gramext.action + (fun _ (e : 'expr) + (_loc : Lexing.position * Lexing.position) -> +- (e : 'e__27))])], ++ (e : 'e__29))])], + Gramext.action +- (fun (a : 'e__27 list) ++ (fun (a : 'e__29 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -4547,9 +4590,9 @@ + Gramext.action + (fun _ (cf : 'class_str_item) + (_loc : Lexing.position * Lexing.position) -> +- (cf : 'e__30))])], ++ (cf : 'e__32))])], + Gramext.action +- (fun (a : 'e__30 list) ++ (fun (a : 'e__32 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -4592,9 +4635,9 @@ + Gramext.action + (fun _ (csf : 'class_sig_item) + (_loc : Lexing.position * Lexing.position) -> +- (csf : 'e__32))])], ++ (csf : 'e__34))])], + Gramext.action +- (fun (a : 'e__32 list) ++ (fun (a : 'e__34 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +@@ -4623,9 +4666,9 @@ + Gramext.action + (fun _ (csf : 'class_sig_item) + (_loc : Lexing.position * Lexing.position) -> +- (csf : 'e__31))])], ++ (csf : 'e__33))])], + Gramext.action +- (fun (a : 'e__31 list) ++ (fun (a : 'e__33 list) + (_loc : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm +Index: camlp4/top/rprint.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v +retrieving revision 1.18 +diff -u -r1.18 rprint.ml +--- camlp4/top/rprint.ml 29 Jun 2005 04:11:26 -0000 1.18 ++++ camlp4/top/rprint.ml 5 Apr 2006 02:26:01 -0000 +@@ -288,8 +288,9 @@ + fprintf ppf "@[<2>method %s%s%s :@ %a;@]" + (if priv then "private " else "") (if virt then "virtual " else "") + name Toploop.print_out_type.val ty +- | Ocsg_value name mut ty -> +- fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "") ++ | Ocsg_value name mut virt ty -> ++ fprintf ppf "@[<2>value %s%s%s :@ %a;@]" ++ (if mut then "mutable " else "") (if virt then "virtual " else "") + name Toploop.print_out_type.val ty ] + ; + diff --git a/experimental/garrigue/variable-names-Tvar.diffs b/experimental/garrigue/variable-names-Tvar.diffs new file mode 100644 index 00000000..99ff6a24 --- /dev/null +++ b/experimental/garrigue/variable-names-Tvar.diffs @@ -0,0 +1,1656 @@ +Index: VERSION +=================================================================== +--- VERSION (リビジョン 11207) ++++ VERSION (作業コピー) +@@ -1,4 +1,4 @@ +-3.13.0+dev6 (2011-07-29) ++3.13.0+dev7 (2011-09-22) + + # The version string is the first line of this file. + # It must be in the format described in stdlib/sys.mli +Index: typing/typemod.ml +=================================================================== +--- typing/typemod.ml (リビジョン 11207) ++++ typing/typemod.ml (作業コピー) +@@ -764,7 +764,7 @@ + Location.prerr_warning smod.pmod_loc + (Warnings.Not_principal "this module unpacking"); + modtype_of_package env smod.pmod_loc p nl tl +- | {desc = Tvar} -> ++ | {desc = Tvar _} -> + raise (Typecore.Error + (smod.pmod_loc, Typecore.Cannot_infer_signature)) + | _ -> +Index: typing/typetexp.ml +=================================================================== +--- typing/typetexp.ml (リビジョン 11207) ++++ typing/typetexp.ml (作業コピー) +@@ -150,7 +150,7 @@ + if strict then raise Already_bound; + v + with Not_found -> +- let v = new_global_var() in ++ let v = new_global_var ~name () in + type_variables := Tbl.add name v !type_variables; + v + +@@ -165,8 +165,8 @@ + Tpoly _ -> ty + | _ -> Ctype.newty (Tpoly (ty, [])) + +-let new_pre_univar () = +- let v = newvar () in pre_univars := v :: !pre_univars; v ++let new_pre_univar ?name () = ++ let v = newvar ?name () in pre_univars := v :: !pre_univars; v + + let rec swap_list = function + x :: y :: l -> y :: x :: swap_list l +@@ -190,7 +190,8 @@ + instance (fst(Tbl.find name !used_variables)) + with Not_found -> + let v = +- if policy = Univars then new_pre_univar () else newvar () in ++ if policy = Univars then new_pre_univar ~name () else newvar ~name () ++ in + used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; + v + end +@@ -333,7 +334,14 @@ + end_def (); + generalize_structure t; + end; +- instance t ++ let t = instance t in ++ let px = Btype.proxy t in ++ begin match px.desc with ++ | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) ++ | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) ++ | _ -> () ++ end; ++ t + end + | Ptyp_variant(fields, closed, present) -> + let name = ref None in +@@ -388,7 +396,7 @@ + {desc=Tvariant row}, _ when Btype.static_row row -> + let row = Btype.row_repr row in + row.row_fields +- | {desc=Tvar}, Some(p, _) -> ++ | {desc=Tvar _}, Some(p, _) -> + raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) + | _ -> + raise(Error(sty.ptyp_loc, Not_a_variant ty)) +@@ -431,7 +439,7 @@ + newty (Tvariant row) + | Ptyp_poly(vars, st) -> + begin_def(); +- let new_univars = List.map (fun name -> name, newvar()) vars in ++ let new_univars = List.map (fun name -> name, newvar ~name ()) vars in + let old_univars = !univars in + univars := new_univars @ !univars; + let ty = transl_type env policy st in +@@ -443,10 +451,12 @@ + (fun tyl (name, ty1) -> + let v = Btype.proxy ty1 in + if deep_occur v ty then begin +- if v.level <> Btype.generic_level || v.desc <> Tvar then +- raise (Error (styp.ptyp_loc, Cannot_quantify (name, v))); +- v.desc <- Tunivar; +- v :: tyl ++ match v.desc with ++ Tvar name when v.level = Btype.generic_level -> ++ v.desc <- Tunivar name; ++ v :: tyl ++ | _ -> ++ raise (Error (styp.ptyp_loc, Cannot_quantify (name, v))) + end else tyl) + [] new_univars + in +@@ -483,7 +493,7 @@ + match ty.desc with + | Tvariant row -> + let row = Btype.row_repr row in +- if (Btype.row_more row).desc = Tunivar then ++ if Btype.is_Tunivar (Btype.row_more row) then + ty.desc <- Tvariant + {row with row_fixed=true; + row_fields = List.map +@@ -512,7 +522,7 @@ + then try + r := (loc, v, Tbl.find name !type_variables) :: !r + with Not_found -> +- if fixed && (repr ty).desc = Tvar then ++ if fixed && Btype.is_Tvar (repr ty) then + raise(Error(loc, Unbound_type_variable ("'"^name))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; +@@ -552,8 +562,10 @@ + List.fold_left + (fun acc v -> + let v = repr v in +- if v.level <> Btype.generic_level || v.desc <> Tvar then acc +- else (v.desc <- Tunivar ; v :: acc)) ++ match v.desc with ++ Tvar name when v.level = Btype.generic_level -> ++ v.desc <- Tunivar name; v :: acc ++ | _ -> acc) + [] !pre_univars + in + make_fixed_univars typ; +@@ -635,8 +647,8 @@ + fprintf ppf "The type variable name %s is not allowed in programs" name + | Cannot_quantify (name, v) -> + fprintf ppf "This type scheme cannot quantify '%s :@ %s." name +- (if v.desc = Tvar then "it escapes this scope" else +- if v.desc = Tunivar then "it is aliased to another variable" ++ (if Btype.is_Tvar v then "it escapes this scope" else ++ if Btype.is_Tunivar v then "it is aliased to another variable" + else "it is not a variable") + | Multiple_constraints_on_type s -> + fprintf ppf "Multiple constraints for type %s" s +Index: typing/btype.ml +=================================================================== +--- typing/btype.ml (リビジョン 11207) ++++ typing/btype.ml (作業コピー) +@@ -35,9 +35,9 @@ + let new_id = ref (-1) + + let newty2 level desc = +- incr new_id; { desc = desc; level = level; id = !new_id } ++ incr new_id; { desc; level; id = !new_id } + let newgenty desc = newty2 generic_level desc +-let newgenvar () = newgenty Tvar ++let newgenvar ?name () = newgenty (Tvar name) + (* + let newmarkedvar level = + incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } +@@ -46,6 +46,11 @@ + { desc = Tvar; level = pivot_level - generic_level; id = !new_id } + *) + ++(**** Check some types ****) ++ ++let is_Tvar = function {desc=Tvar _} -> true | _ -> false ++let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false ++ + (**** Representative of a type ****) + + let rec field_kind_repr = +@@ -139,7 +144,7 @@ + let rec proxy_obj ty = + match ty.desc with + Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty +- | Tvar | Tunivar | Tconstr _ -> ty ++ | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty0 + | _ -> assert false + in proxy_obj ty +@@ -180,13 +185,13 @@ + row.row_fields; + match (repr row.row_more).desc with + Tvariant row -> iter_row f row +- | Tvar | Tunivar | Tsubst _ | Tconstr _ -> ++ | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ -> + Misc.may (fun (_,l) -> List.iter f l) row.row_name + | _ -> assert false + + let iter_type_expr f ty = + match ty.desc with +- Tvar -> () ++ Tvar _ -> () + | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2 + | Ttuple l -> List.iter f l + | Tconstr (_, l, _) -> List.iter f l +@@ -198,7 +203,7 @@ + | Tnil -> () + | Tlink ty -> f ty + | Tsubst ty -> f ty +- | Tunivar -> () ++ | Tunivar _ -> () + | Tpoly (ty, tyl) -> f ty; List.iter f tyl + | Tpackage (_, _, l) -> List.iter f l + +@@ -239,13 +244,13 @@ + encoding during substitution *) + let rec norm_univar ty = + match ty.desc with +- Tunivar | Tsubst _ -> ty ++ Tunivar _ | Tsubst _ -> ty + | Tlink ty -> norm_univar ty + | Ttuple (ty :: _) -> norm_univar ty + | _ -> assert false + + let rec copy_type_desc f = function +- Tvar -> Tvar ++ Tvar _ -> Tvar None (* forget the name *) + | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) + | Ttuple l -> Ttuple (List.map f l) + | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) +@@ -258,7 +263,7 @@ + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f ty.desc + | Tsubst ty -> assert false +- | Tunivar -> Tunivar ++ | Tunivar _ as ty -> ty (* keep the name *) + | Tpoly (ty, tyl) -> + let tyl = List.map (fun x -> norm_univar (f x)) tyl in + Tpoly (f ty, tyl) +@@ -447,7 +452,7 @@ + | Cuniv of type_expr option ref * type_expr option + + let undo_change = function +- Ctype (ty, desc) -> ty.desc <- desc ++ Ctype (ty, desc) -> ty.desc <- desc + | Clevel (ty, level) -> ty.level <- level + | Cname (r, v) -> r := v + | Crow (r, v) -> r := v +@@ -474,7 +479,22 @@ + + let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +-let link_type ty ty' = log_type ty; ty.desc <- Tlink ty' ++let link_type ty ty' = ++ log_type ty; ++ let desc = ty.desc in ++ ty.desc <- Tlink ty'; ++ (* Name is a user-supplied name for this unification variable (obtained ++ * through a type annotation for instance). *) ++ match desc, ty'.desc with ++ Tvar name, Tvar name' -> ++ begin match name, name' with ++ | Some _, None -> log_type ty'; ty'.desc <- Tvar name ++ | None, Some _ -> () ++ | Some _, Some _ -> ++ if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name) ++ | None, None -> () ++ end ++ | _ -> () + (* ; assert (check_memorized_abbrevs ()) *) + (* ; check_expans [] ty' *) + let set_level ty level = +Index: typing/typecore.ml +=================================================================== +--- typing/typecore.ml (リビジョン 11207) ++++ typing/typecore.ml (作業コピー) +@@ -633,7 +633,7 @@ + List.iter generalize vars; + let instantiated tv = + let tv = expand_head !env tv in +- tv.desc <> Tvar || tv.level <> generic_level 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))) + end; +@@ -1126,7 +1126,7 @@ + Tarrow (l, _, ty_res, _) -> + list_labels_aux env (ty::visited) (l::ls) ty_res + | _ -> +- List.rev ls, ty.desc = Tvar ++ List.rev ls, is_Tvar ty + + let list_labels env ty = list_labels_aux env [] [] ty + +@@ -1142,9 +1142,10 @@ + (fun t -> + let t = repr t in + generalize t; +- if t.desc = Tvar && t.level = generic_level then +- (log_type t; t.desc <- Tunivar; true) +- else false) ++ match t.desc with ++ Tvar name when t.level = generic_level -> ++ log_type t; t.desc <- Tunivar name; true ++ | _ -> false) + vars in + if List.length vars = List.length vars' then () else + let ty = newgenty (Tpoly(repr exp.exp_type, vars')) +@@ -1158,7 +1159,7 @@ + match (expand_head env exp.exp_type).desc with + | Tarrow _ -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application +- | Tvar -> () ++ | Tvar _ -> () + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | _ -> + if statement then +@@ -1742,7 +1743,7 @@ + let (id, typ) = + filter_self_method env met Private meths privty + in +- if (repr typ).desc = Tvar then ++ if is_Tvar (repr typ) then + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + (Texp_send(obj, Tmeth_val id), typ) +@@ -1797,7 +1798,7 @@ + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly false tl ty) +- | {desc = Tvar} as ty -> ++ | {desc = Tvar _} as ty -> + let ty' = newvar () in + unify env (instance ty) (newty(Tpoly(ty',[]))); + (* if not !Clflags.nolabels then +@@ -1979,7 +1980,7 @@ + end_def (); + check_univars env false "method" exp ty_expected vars; + re { exp with exp_type = instance ty } +- | Tvar -> ++ | Tvar _ -> + let exp = type_exp env sbody in + let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in + unify_exp env exp ty; +@@ -2038,7 +2039,7 @@ + Location.prerr_warning loc + (Warnings.Not_principal "this module packing"); + (p, nl, tl) +- | {desc = Tvar} -> ++ | {desc = Tvar _} -> + raise (Error (loc, Cannot_infer_signature)) + | _ -> + raise (Error (loc, Not_a_packed_module ty_expected)) +@@ -2128,7 +2129,7 @@ + ty_fun + | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic -> + args, ty_fun, no_labels ty_res' +- | Tvar -> args, ty_fun, false ++ | Tvar _ -> args, ty_fun, false + | _ -> [], texp.exp_type, false + in + let args, ty_fun', simple_res = make_args [] texp.exp_type in +@@ -2192,7 +2193,7 @@ + let (ty1, ty2) = + let ty_fun = expand_head env ty_fun in + match ty_fun.desc with +- Tvar -> ++ Tvar _ -> + let t1 = newvar () and t2 = newvar () in + let not_identity = function + Texp_ident(_,{val_kind=Val_prim +@@ -2335,7 +2336,7 @@ + begin match (expand_head env exp.exp_type).desc with + | Tarrow _ -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application +- | Tvar -> ++ | Tvar _ -> + add_delayed_check (fun () -> check_application_result env false exp) + | _ -> () + end; +@@ -2404,9 +2405,9 @@ + | Tarrow _ -> + Location.prerr_warning loc Warnings.Partial_application + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () +- | Tvar when ty.level > tv.level -> ++ | Tvar _ when ty.level > tv.level -> + Location.prerr_warning loc Warnings.Nonreturning_statement +- | Tvar -> ++ | Tvar _ -> + add_delayed_check (fun () -> check_application_result env true exp) + | _ -> + Location.prerr_warning loc Warnings.Statement_type +Index: typing/btype.mli +=================================================================== +--- typing/btype.mli (リビジョン 11207) ++++ typing/btype.mli (作業コピー) +@@ -23,7 +23,7 @@ + (* Create a type *) + val newgenty: type_desc -> type_expr + (* Create a generic type *) +-val newgenvar: unit -> type_expr ++val newgenvar: ?name:string -> unit -> type_expr + (* Return a fresh generic variable *) + + (* Use Tsubst instead +@@ -33,6 +33,9 @@ + (* Return a fresh marked generic variable *) + *) + ++val is_Tvar: type_expr -> bool ++val is_Tunivar: type_expr -> bool ++ + val repr: type_expr -> type_expr + (* Return the canonical representative of a type. *) + +Index: typing/ctype.mli +=================================================================== +--- typing/ctype.mli (リビジョン 11207) ++++ typing/ctype.mli (作業コピー) +@@ -41,9 +41,10 @@ + (* This pair of functions is only used in Typetexp *) + + val newty: type_desc -> type_expr +-val newvar: unit -> type_expr ++val newvar: ?name:string -> unit -> type_expr ++val newvar2: ?name:string -> int -> type_expr + (* Return a fresh variable *) +-val new_global_var: unit -> type_expr ++val new_global_var: ?name:string -> unit -> type_expr + (* Return a fresh variable, bound at toplevel + (as type variables ['a] in type constraints). *) + val newobj: type_expr -> type_expr +Index: typing/datarepr.ml +=================================================================== +--- typing/datarepr.ml (リビジョン 11207) ++++ typing/datarepr.ml (作業コピー) +@@ -28,7 +28,7 @@ + if ty.level >= lowest_level then begin + ty.level <- pivot_level - ty.level; + match ty.desc with +- | Tvar -> ++ | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + let row = row_repr row in +Index: typing/typeclass.ml +=================================================================== +--- typing/typeclass.ml (リビジョン 11207) ++++ typing/typeclass.ml (作業コピー) +@@ -532,7 +532,7 @@ + (Typetexp.transl_simple_type val_env false sty) ty + end; + begin match (Ctype.repr ty).desc with +- Tvar -> ++ Tvar _ -> + let ty' = Ctype.newvar () in + Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; + Ctype.unify val_env (type_approx val_env sbody) ty' +Index: typing/typedecl.ml +=================================================================== +--- typing/typedecl.ml (リビジョン 11207) ++++ typing/typedecl.ml (作業コピー) +@@ -111,7 +111,7 @@ + | _ -> + raise (Error (loc, Bad_fixed_type "is not an object or variant")) + in +- if rv.desc <> Tvar then ++ if not (Btype.is_Tvar rv) then + raise (Error (loc, Bad_fixed_type "has no row variable")); + rv.desc <- Tconstr (p, decl.type_params, ref Mnil) + +@@ -503,7 +503,7 @@ + compute_same row.row_more + | Tpoly (ty, _) -> + compute_same ty +- | Tvar | Tnil | Tlink _ | Tunivar -> () ++ | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, _, tyl) -> + List.iter (compute_variance_rec true true true) tyl + end +@@ -546,7 +546,7 @@ + in + List.iter2 + (fun (ty, co, cn, ct) (c, n) -> +- if ty.desc <> Tvar then begin ++ if not (Btype.is_Tvar ty) then begin + co := c; cn := n; ct := n; + compute_variance env tvl2 c n n ty + end) +@@ -571,7 +571,7 @@ + + let rec anonymous env ty = + match (Ctype.expand_head env ty).desc with +- | Tvar -> false ++ | Tvar _ -> false + | Tobject (fi, _) -> + let _, rv = Ctype.flatten_fields fi in anonymous env rv + | Tvariant row -> +Index: typing/types.mli +=================================================================== +--- typing/types.mli (リビジョン 11207) ++++ typing/types.mli (作業コピー) +@@ -24,7 +24,7 @@ + mutable id: int } + + and type_desc = +- Tvar ++ Tvar of string option + | Tarrow of label * type_expr * type_expr * commutable + | Ttuple of type_expr list + | Tconstr of Path.t * type_expr list * abbrev_memo ref +@@ -34,7 +34,7 @@ + | Tlink of type_expr + | Tsubst of type_expr (* for copying *) + | Tvariant of row_desc +- | Tunivar ++ | Tunivar of string option + | Tpoly of type_expr * type_expr list + | Tpackage of Path.t * string list * type_expr list + +Index: typing/ctype.ml +=================================================================== +--- typing/ctype.ml (リビジョン 11207) ++++ typing/ctype.ml (作業コピー) +@@ -153,9 +153,9 @@ + let newty desc = newty2 !current_level desc + let new_global_ty desc = newty2 !global_level desc + +-let newvar () = newty2 !current_level Tvar +-let newvar2 level = newty2 level Tvar +-let new_global_var () = newty2 !global_level Tvar ++let newvar ?name () = newty2 !current_level (Tvar name) ++let newvar2 ?name level = newty2 level (Tvar name) ++let new_global_var ?name () = newty2 !global_level (Tvar name) + + let newobj fields = newty (Tobject (fields, ref None)) + +@@ -297,14 +297,12 @@ + + let opened_object ty = + match (object_row ty).desc with +- | Tvar -> true +- | Tunivar -> true +- | Tconstr _ -> true +- | _ -> false ++ | Tvar _ | Tunivar _ | Tconstr _ -> true ++ | _ -> false + + let concrete_object ty = + match (object_row ty).desc with +- | Tvar -> false ++ | Tvar _ -> false + | _ -> true + + (**** Close an object ****) +@@ -313,7 +311,7 @@ + let rec close ty = + let ty = repr ty in + match ty.desc with +- Tvar -> ++ Tvar _ -> + link_type ty (newty2 ty.level Tnil) + | Tfield(_, _, _, ty') -> close ty' + | _ -> assert false +@@ -329,7 +327,7 @@ + let ty = repr ty in + match ty.desc with + Tfield (_, _, _, ty) -> find ty +- | Tvar -> ty ++ | Tvar _ -> ty + | _ -> assert false + in + match (repr ty).desc with +@@ -434,7 +432,7 @@ + let level = ty.level in + ty.level <- pivot_level - level; + match ty.desc with +- Tvar when level <> generic_level -> ++ Tvar _ when level <> generic_level -> + raise Non_closed + | Tfield(_, kind, t1, t2) -> + if field_kind_repr kind = Fpresent then +@@ -468,7 +466,7 @@ + if ty.level >= lowest_level then begin + ty.level <- pivot_level - ty.level; + begin match ty.desc, !really_closed with +- Tvar, _ -> ++ Tvar _, _ -> + free_variables := (ty, real) :: !free_variables + | Tconstr (path, tl, _), Some env -> + begin try +@@ -639,7 +637,7 @@ + let rec generalize_structure var_level ty = + let ty = repr ty in + if ty.level <> generic_level then begin +- if ty.desc = Tvar && ty.level > var_level then ++ if is_Tvar ty && ty.level > var_level then + set_level ty var_level + else if ty.level > !current_level then begin + set_level ty generic_level; +@@ -858,7 +856,7 @@ + TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); + List.iter (add_univar univ) inv.inv_parents + in +- TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv) ++ TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) + inverted; + fun ty -> + try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty +@@ -913,7 +911,7 @@ + if keep then ty.level else !current_level + else generic_level + in +- if forget <> generic_level then newty2 forget Tvar else ++ if forget <> generic_level then newty2 forget (Tvar None) else + let desc = ty.desc in + save_desc ty desc; + let t = newvar() in (* Stub *) +@@ -959,7 +957,7 @@ + | Tconstr _ -> + if keep then save_desc more more.desc; + copy more +- | Tvar | Tunivar -> ++ | Tvar _ | Tunivar _ -> + save_desc more more.desc; + if keep then more else newty more.desc + | _ -> assert false +@@ -1117,7 +1115,7 @@ + t + else try + let t, bound_t = List.assq ty visited in +- let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in ++ let dl = if is_Tunivar ty then [] else diff_list bound bound_t in + if dl <> [] && conflicts univars dl then raise Not_found; + t + with Not_found -> begin +@@ -1134,14 +1132,14 @@ + let row = row_repr row0 in + let more = repr row.row_more in + (* We shall really check the level on the row variable *) +- let keep = more.desc = Tvar && more.level <> generic_level in ++ let keep = is_Tvar more && more.level <> generic_level in + let more' = copy_rec more in +- let fixed' = fixed && (repr more').desc = Tvar in ++ let fixed' = fixed && is_Tvar (repr more') in + let row = copy_row copy_rec fixed' row keep more' in + Tvariant row + | Tpoly (t1, tl) -> + let tl = List.map repr tl in +- let tl' = List.map (fun t -> newty Tunivar) tl in ++ let tl' = List.map (fun t -> newty t.desc) tl in + let bound = tl @ bound in + let visited = + List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in +@@ -1395,7 +1393,7 @@ + let rec full_expand env ty = + let ty = repr (expand_head env ty) in + match ty.desc with +- Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar -> ++ Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> + newty2 ty.level (Tobject (fi, ref None)) + | _ -> + ty +@@ -1570,8 +1568,8 @@ + true + then + match ty.desc with +- Tunivar -> +- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()]) ++ Tunivar _ -> ++ if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()]) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + occur_rec bound ty +@@ -1620,7 +1618,7 @@ + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () + else occur t +- | Tunivar -> ++ | Tunivar _ -> + if TypeSet.mem t family then raise Occur + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> +@@ -1784,7 +1782,7 @@ + t + end; + iter_type_expr (iterator visited) ty +- | Tvar -> ++ | Tvar _ -> + let t = create_fresh_constr ty.level false in + link_type ty t + | _ -> +@@ -1862,8 +1860,8 @@ + let t2 = repr t2 in + if t1 == t2 then () else + match (t1.desc, t2.desc) with +- | (Tvar, _) +- | (_, Tvar) -> ++ | (Tvar _, _) ++ | (_, Tvar _) -> + fatal_error "types should not include variables" + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () +@@ -1877,7 +1875,7 @@ + with Not_found -> + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with +- (Tvar, Tvar) -> ++ (Tvar _, Tvar _) -> + fatal_error "types should not include variables" + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 + || !Clflags.classic && not (is_optional l1 || is_optional l2) -> +@@ -1903,7 +1901,7 @@ + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (mcomp type_pairs subst env) +- | (Tunivar, Tunivar) -> ++ | (Tunivar _, Tunivar _) -> + unify_univar t1' t2' !univar_pairs + | (_, _) -> + raise (Unify []) +@@ -2048,21 +2046,21 @@ + try + type_changed := true; + match (t1.desc, t2.desc) with +- (Tvar, Tconstr _) when deep_occur t1 t2 -> ++ (Tvar _, Tconstr _) when deep_occur t1 t2 -> + unify2 env t1 t2 +- | (Tconstr _, Tvar) when deep_occur t2 t1 -> ++ | (Tconstr _, Tvar _) when deep_occur t2 t1 -> + unify2 env t1 t2 +- | (Tvar, _) -> ++ | (Tvar _, _) -> + occur !env t1 t2; + occur_univar !env t2; + link_type t1 t2; + update_level !env t1.level t2 +- | (_, Tvar) -> ++ | (_, Tvar _) -> + occur !env t2 t1; + occur_univar !env t1; + link_type t2 t1; + update_level !env t2.level t1 +- | (Tunivar, Tunivar) -> ++ | (Tunivar _, Tunivar _) -> + unify_univar t1 t2 !univar_pairs; + update_level !env t1.level t2; + link_type t1 t2 +@@ -2104,7 +2102,7 @@ + (* Assumes either [t1 == t1'] or [t2 != t2'] *) + let d1 = t1'.desc and d2 = t2'.desc in + match (d1, d2) with (* handle univars specially *) +- (Tunivar, Tunivar) -> ++ (Tunivar _, Tunivar _) -> + unify_univar t1' t2' !univar_pairs; + update_level !env t1'.level t2'; + link_type t1' t2' +@@ -2127,12 +2125,12 @@ + | Old -> f () (* old_link was already called *) + in + match d1, d2 with +- | Tvar,_ -> ++ | Tvar _, _ -> + occur !env t1 t2'; + occur_univar !env t2; + update_level !env t1'.level t2; + link_type t1' t2; +- | _, Tvar -> ++ | _, Tvar _ -> + occur !env t2 t1'; + occur_univar !env t1; + update_level !env t2'.level t1; +@@ -2149,8 +2147,8 @@ + add_type_equality t1' t2' end; + try + begin match (d1, d2) with +- | (Tvar, _) +- | (_, Tvar) -> ++ | (Tvar _, _) ++ | (_, Tvar _) -> + (* cases taken care of *) + assert false + | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 +@@ -2214,8 +2212,9 @@ + (* Type [t2'] may have been instantiated by [unify_fields] *) + (* XXX One should do some kind of unification... *) + begin match (repr t2').desc with +- Tobject (_, {contents = Some (_, va::_)}) +- when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] -> ++ Tobject (_, {contents = Some (_, va::_)}) when ++ (match (repr va).desc with ++ Tvar _|Tunivar _|Tnil -> true | _ -> false) -> + () + | Tobject (_, nm2) -> + set_name nm2 !nm1 +@@ -2290,16 +2289,32 @@ + raise (Unify []); + List.iter2 (unify env) tl1 tl2 + ++(* Build a fresh row variable for unification *) ++and make_rowvar level use1 rest1 use2 rest2 = ++ let set_name ty name = ++ match ty.desc with ++ Tvar None -> log_type ty; ty.desc <- Tvar name ++ | _ -> () ++ in ++ let name = ++ match rest1.desc, rest2.desc with ++ Tvar (Some _ as name1), Tvar (Some _ as name2) -> ++ if rest1.level <= rest2.level then name1 else name2 ++ | Tvar (Some _ as name), _ -> ++ if use2 then set_name rest2 name; name ++ | _, Tvar (Some _ as name) -> ++ if use1 then set_name rest2 name; name ++ | _ -> None ++ in ++ if use1 then rest1 else ++ if use2 then rest2 else newvar2 ?name level ++ + and unify_fields env ty1 ty2 = (* Optimization *) + let (fields1, rest1) = flatten_fields ty1 + and (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let l1 = (repr ty1).level and l2 = (repr ty2).level in +- let va = +- if miss1 = [] then rest2 +- else if miss2 = [] then rest1 +- else newty2 (min l1 l2) Tvar +- in ++ let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let d1 = rest1.desc and d2 = rest2.desc in + try + unify env (build_fields l1 miss1 va) rest2; +@@ -2390,7 +2405,7 @@ + let rm = row_more row in + if row.row_fixed then + if row0.row_more == rm then () else +- if rm.desc = Tvar then link_type rm row0.row_more else ++ if is_Tvar rm then link_type rm row0.row_more else + unify env rm row0.row_more + else + let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in +@@ -2489,7 +2504,7 @@ + let t1 = repr t1 and t2 = repr t2 in + if t1 == t2 then () else + match t1.desc with +- Tvar -> ++ Tvar _ -> + begin try + occur env t1 t2; + update_level env t1.level t2; +@@ -2527,7 +2542,7 @@ + let rec filter_arrow env t l = + let t = expand_head_unif env t in + match t.desc with +- Tvar -> ++ Tvar _ -> + let lv = t.level in + let t1 = newvar2 lv and t2 = newvar2 lv in + let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in +@@ -2543,7 +2558,7 @@ + let rec filter_method_field env name priv ty = + let ty = repr ty in + match ty.desc with +- Tvar -> ++ Tvar _ -> + let level = ty.level in + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = newty2 level (Tfield (name, +@@ -2570,7 +2585,7 @@ + let rec filter_method env name priv ty = + let ty = expand_head_unif env ty in + match ty.desc with +- Tvar -> ++ Tvar _ -> + let ty1 = newvar () in + let ty' = newobj ty1 in + update_level env ty.level ty'; +@@ -2606,7 +2621,7 @@ + let rec occur ty = + let ty = repr ty in + if ty.level > level then begin +- if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur; ++ if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; + ty.level <- pivot_level - ty.level; + match ty.desc with + Tvariant row when static_row row -> +@@ -2636,7 +2651,7 @@ + + try + match (t1.desc, t2.desc) with +- (Tvar, _) when may_instantiate inst_nongen t1 -> ++ (Tvar _, _) when may_instantiate inst_nongen t1 -> + moregen_occur env t1.level t2; + occur env t1 t2; + link_type t1 t2 +@@ -2653,7 +2668,7 @@ + with Not_found -> + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with +- (Tvar, _) when may_instantiate inst_nongen t1' -> ++ (Tvar _, _) when may_instantiate inst_nongen t1' -> + moregen_occur env t1'.level t2; + link_type t1' t2 + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 +@@ -2684,7 +2699,7 @@ + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (moregen inst_nongen type_pairs env) +- | (Tunivar, Tunivar) -> ++ | (Tunivar _, Tunivar _) -> + unify_univar t1' t2' !univar_pairs + | (_, _) -> + raise (Unify []) +@@ -2725,7 +2740,7 @@ + let row1 = row_repr row1 and row2 = row_repr row2 in + let rm1 = repr row1.row_more and rm2 = repr row2.row_more in + if rm1 == rm2 then () else +- let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in ++ let may_inst = is_Tvar rm1 && may_instantiate inst_nongen rm1 in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let r1, r2 = + if row2.row_closed then +@@ -2735,9 +2750,9 @@ + if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) + then raise (Unify []); + begin match rm1.desc, rm2.desc with +- Tunivar, Tunivar -> ++ Tunivar _, Tunivar _ -> + unify_univar rm1 rm2 !univar_pairs +- | Tunivar, _ | _, Tunivar -> ++ | Tunivar _, _ | _, Tunivar _ -> + raise (Unify []) + | _ when static_row row1 -> () + | _ when may_inst -> +@@ -2828,13 +2843,13 @@ + if ty.level >= lowest_level then begin + ty.level <- pivot_level - ty.level; + match ty.desc with +- | Tvar -> ++ | Tvar _ -> + if not (List.memq ty !vars) then vars := ty :: !vars + | Tvariant row -> + let row = row_repr row in + let more = repr row.row_more in +- if more.desc = Tvar && not row.row_fixed then begin +- let more' = newty2 more.level Tvar in ++ if is_Tvar more && not row.row_fixed then begin ++ let more' = newty2 more.level more.desc in + let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} + in link_type more (newty2 ty.level (Tvariant row')) + end; +@@ -2857,7 +2872,7 @@ + (fun ty -> + let ty = expand_head env ty in + if List.memq ty !tyl then false else +- (tyl := ty :: !tyl; ty.desc = Tvar)) ++ (tyl := ty :: !tyl; is_Tvar ty)) + vars + + let matches env ty ty' = +@@ -2901,7 +2916,7 @@ + + try + match (t1.desc, t2.desc) with +- (Tvar, Tvar) when rename -> ++ (Tvar _, Tvar _) when rename -> + begin try + normalize_subst subst; + if List.assq t1 !subst != t2 then raise (Unify []) +@@ -2922,7 +2937,7 @@ + with Not_found -> + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with +- (Tvar, Tvar) when rename -> ++ (Tvar _, Tvar _) when rename -> + begin try + normalize_subst subst; + if List.assq t1' !subst != t2' then raise (Unify []) +@@ -2956,7 +2971,7 @@ + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (eqtype rename type_pairs subst env) +- | (Tunivar, Tunivar) -> ++ | (Tunivar _, Tunivar _) -> + unify_univar t1' t2' !univar_pairs + | (_, _) -> + raise (Unify []) +@@ -3405,7 +3420,7 @@ + let rec build_subtype env visited loops posi level t = + let t = repr t in + match t.desc with +- Tvar -> ++ Tvar _ -> + if posi then + try + let t' = List.assq t loops in +@@ -3454,13 +3469,13 @@ + as this occurence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; +- ty.desc <- Tvar; ++ ty.desc <- Tvar None; + let t'' = newvar () in + let loops = (ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let (ty1', c) = + build_subtype env [t'] loops posi (pred_enlarge level') ty1 in +- assert (t''.desc = Tvar); ++ assert (is_Tvar t''); + let nm = + if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in + t''.desc <- Tobject (ty1', ref nm); +@@ -3559,7 +3574,7 @@ + let (t1', c) = build_subtype env visited loops posi level t1 in + if c > Unchanged then (newty (Tpoly(t1', tl)), c) + else (t, Unchanged) +- | Tunivar | Tpackage _ -> ++ | Tunivar _ | Tpackage _ -> + (t, Unchanged) + + let enlarge_type env ty = +@@ -3623,7 +3638,7 @@ + with Not_found -> + TypePairs.add subtypes (t1, t2) (); + match (t1.desc, t2.desc) with +- (Tvar, _) | (_, Tvar) -> ++ (Tvar _, _) | (_, Tvar _) -> + (trace, t1, t2, !univar_pairs)::cstrs + | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 + || !Clflags.classic && not (is_optional l1 || is_optional l2) -> +@@ -3659,7 +3674,7 @@ + | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 -> + subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs + | (Tobject (f1, _), Tobject (f2, _)) +- when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar -> ++ when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> + (* Same row variable implies same object. *) + (trace, t1, t2, !univar_pairs)::cstrs + | (Tobject (f1, _), Tobject (f2, _)) -> +@@ -3731,7 +3746,7 @@ + match more1.desc, more2.desc with + Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> + subtype_rec env ((more1,more2)::trace) more1 more2 cstrs +- | (Tvar|Tconstr _), (Tvar|Tconstr _) ++ | (Tvar _|Tconstr _), (Tvar _|Tconstr _) + when row1.row_closed && r1 = [] -> + List.fold_left + (fun cstrs (_,f1,f2) -> +@@ -3745,7 +3760,7 @@ + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs +- | Tunivar, Tunivar ++ | Tunivar _, Tunivar _ + when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> + let cstrs = + subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in +@@ -3789,19 +3804,19 @@ + match ty.desc with + Tfield (s, k, t1, t2) -> + newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) +- | Tvar | Tnil -> ++ | Tvar _ | Tnil -> + newty2 ty.level ty.desc +- | Tunivar -> ++ | Tunivar _ -> + ty + | Tconstr _ -> +- newty2 ty.level Tvar ++ newvar2 ty.level + | _ -> + assert false + + let unalias ty = + let ty = repr ty in + match ty.desc with +- Tvar | Tunivar -> ++ Tvar _ | Tunivar _ -> + ty + | Tvariant row -> + let row = row_repr row in +@@ -3875,7 +3890,7 @@ + set_name nm None + else let v' = repr v in + begin match v'.desc with +- | Tvar|Tunivar -> ++ | Tvar _ | Tunivar _ -> + if v' != v then set_name nm (Some (n, v' :: l)) + | Tnil -> + log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) +@@ -3917,7 +3932,7 @@ + + let rec nondep_type_rec env id ty = + match ty.desc with +- Tvar | Tunivar -> ty ++ Tvar _ | Tunivar _ -> ty + | Tlink ty -> nondep_type_rec env id ty + | _ -> try TypeHash.find nondep_hash ty + with Not_found -> +@@ -3987,7 +4002,7 @@ + + let unroll_abbrev id tl ty = + let ty = repr ty and path = Path.Pident id in +- if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) ++ if is_Tvar ty || (List.exists (deep_occur ty) tl) + || is_object_type path then + ty + else +Index: typing/printtyp.ml +=================================================================== +--- typing/printtyp.ml (リビジョン 11207) ++++ typing/printtyp.ml (作業コピー) +@@ -109,6 +109,10 @@ + | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem + | Mlink rem -> list_of_memo !rem + ++let print_name ppf = function ++ None -> fprintf ppf "None" ++ | Some name -> fprintf ppf "\"%s\"" name ++ + let visited = ref [] + let rec raw_type ppf ty = + let ty = safe_repr [] ty in +@@ -119,7 +123,7 @@ + end + and raw_type_list tl = raw_list raw_type tl + and raw_type_desc ppf = function +- Tvar -> fprintf ppf "Tvar" ++ Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow(l,t1,t2,c) -> + fprintf ppf "@[Tarrow(%s,@,%a,@,%a,@,%s)@]" + l raw_type t1 raw_type t2 +@@ -143,7 +147,7 @@ + | Tnil -> fprintf ppf "Tnil" + | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t + | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t +- | Tunivar -> fprintf ppf "Tunivar" ++ | Tunivar name -> fprintf ppf "Tunivar %a" print_name name + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t +@@ -189,28 +193,61 @@ + + let names = ref ([] : (type_expr * string) list) + let name_counter = ref 0 ++let named_vars = ref ([] : string list) + +-let reset_names () = names := []; name_counter := 0 ++let reset_names () = names := []; name_counter := 0; named_vars := [] ++let add_named_var ty = ++ match ty.desc with ++ Tvar (Some name) | Tunivar (Some name) -> ++ if List.mem name !named_vars then () else ++ named_vars := name :: !named_vars ++ | _ -> () + +-let new_name () = ++let rec new_name () = + let name = + if !name_counter < 26 + then String.make 1 (Char.chr(97 + !name_counter)) + else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ + string_of_int(!name_counter / 26) in + incr name_counter; +- name ++ if List.mem name !named_vars ++ || List.exists (fun (_, name') -> name = name') !names ++ then new_name () ++ else name + + let name_of_type t = ++ (* We've already been through repr at this stage, so t is our representative ++ of the union-find class. *) + try List.assq t !names with Not_found -> +- let name = new_name () in ++ let name = ++ match t.desc with ++ Tvar (Some name) | Tunivar (Some name) -> ++ (* Some part of the type we've already printed has assigned another ++ * unification variable to that name. We want to keep the name, so try ++ * adding a number until we find a name that's not taken. *) ++ let current_name = ref name in ++ let i = ref 0 in ++ while List.exists (fun (_, name') -> !current_name = name') !names do ++ current_name := name ^ (string_of_int !i); ++ i := !i + 1; ++ done; ++ !current_name ++ | _ -> ++ (* No name available, create a new one *) ++ new_name () ++ in + names := (t, name) :: !names; + name + + let check_name_of_type t = ignore(name_of_type t) + ++let remove_names tyl = ++ let tyl = List.map repr tyl in ++ names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names ++ ++ + let non_gen_mark sch ty = +- if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else "" ++ if sch && is_Tvar ty && ty.level <> generic_level then "_" else "" + + let print_name_of_type sch ppf t = + fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t) +@@ -225,9 +262,13 @@ + let is_aliased ty = List.memq (proxy ty) !aliased + let add_alias ty = + let px = proxy ty in +- if not (is_aliased px) then aliased := px :: !aliased ++ if not (is_aliased px) then begin ++ aliased := px :: !aliased; ++ add_named_var px ++ end ++ + let aliasable ty = +- match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true ++ match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true + + let namable_row row = + row.row_name <> None && +@@ -245,7 +286,7 @@ + if List.memq px visited && aliasable ty then add_alias px else + let visited = px :: visited in + match ty.desc with +- | Tvar -> () ++ | Tvar _ -> add_named_var ty + | Tarrow(_, ty1, ty2, _) -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl +@@ -290,7 +331,7 @@ + | Tpoly (ty, tyl) -> + List.iter (fun t -> add_alias t) tyl; + mark_loops_rec visited ty +- | Tunivar -> () ++ | Tunivar _ -> add_named_var ty + + let mark_loops ty = + normalize_type Env.empty ty; +@@ -322,7 +363,7 @@ + + let pr_typ () = + match ty.desc with +- | Tvar -> ++ | Tvar _ -> + Otyp_var (is_non_gen sch ty, name_of_type ty) + | Tarrow(l, ty1, ty2, _) -> + let pr_arrow l ty1 ty2 = +@@ -387,16 +428,22 @@ + | Tpoly (ty, []) -> + tree_of_typexp sch ty + | Tpoly (ty, tyl) -> ++ (*let print_names () = ++ List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; ++ prerr_string "; " in *) + let tyl = List.map repr tyl in +- (* let tyl = List.filter is_aliased tyl in *) + if tyl = [] then tree_of_typexp sch ty else begin + let old_delayed = !delayed in ++ (* Make the names delayed, so that the real type is ++ printed once when used as proxy *) + List.iter add_delayed tyl; + let tl = List.map name_of_type tyl in + let tr = Otyp_poly (tl, tree_of_typexp sch ty) in ++ (* Forget names when we leave scope *) ++ remove_names tyl; + delayed := old_delayed; tr + end +- | Tunivar -> ++ | Tunivar _ -> + Otyp_var (false, name_of_type ty) + | Tpackage (p, n, tyl) -> + Otyp_module (Path.name p, n, tree_of_typlist sch tyl) +@@ -446,13 +493,13 @@ + end + + and is_non_gen sch ty = +- sch && ty.desc = Tvar && ty.level <> generic_level ++ sch && is_Tvar ty && ty.level <> generic_level + + and tree_of_typfields sch rest = function + | [] -> + let rest = + match rest.desc with +- | Tvar | Tunivar -> Some (is_non_gen sch rest) ++ | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) + | Tconstr _ -> Some false + | Tnil -> None + | _ -> fatal_error "typfields (1)" +@@ -564,7 +611,7 @@ + let vari = + List.map2 + (fun ty (co,cn,ct) -> +- if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true)) ++ if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true)) + decl.type_params decl.type_variance + in + (Ident.name id, +@@ -645,16 +692,18 @@ + + let method_type (_, kind, ty) = + match field_kind_repr kind, repr ty with +- Fpresent, {desc=Tpoly(ty, _)} -> ty +- | _ , ty -> ty ++ Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) ++ | _ , ty -> (ty, []) + + let tree_of_metho sch concrete csil (lab, kind, ty) = + if lab <> dummy_method then begin + let kind = field_kind_repr kind in + let priv = kind <> Fpresent in + let virt = not (Concr.mem lab concrete) in +- let ty = method_type (lab, kind, ty) in +- Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil ++ let (ty, tyl) = method_type (lab, kind, ty) in ++ let tty = tree_of_typexp sch ty in ++ remove_names tyl; ++ Ocsg_method (lab, priv, virt, tty) :: csil + end + else csil + +@@ -662,7 +711,7 @@ + | Tcty_constr (p, tyl, cty) -> + let sty = Ctype.self_type cty in + if List.memq (proxy sty) !visited_objects +- || List.exists (fun ty -> (repr ty).desc <> Tvar) params ++ || not (List.for_all is_Tvar params) + || List.exists (deep_occur sty) tyl + then prepare_class_type params cty + else List.iter mark_loops tyl +@@ -675,7 +724,7 @@ + let (fields, _) = + Ctype.flatten_fields (Ctype.object_fields sign.cty_self) + in +- List.iter (fun met -> mark_loops (method_type met)) fields; ++ List.iter (fun met -> mark_loops (fst (method_type met))) fields; + Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars + | Tcty_fun (_, ty, cty) -> + mark_loops ty; +@@ -686,7 +735,7 @@ + | Tcty_constr (p', tyl, cty) -> + let sty = Ctype.self_type cty in + if List.memq (proxy sty) !visited_objects +- || List.exists (fun ty -> (repr ty).desc <> Tvar) params ++ || not (List.for_all is_Tvar params) + then + tree_of_class_type sch params cty + else +@@ -743,7 +792,7 @@ + (match tree_of_typexp true param with + Otyp_var (_, s) -> s + | _ -> "?"), +- if (repr param).desc = Tvar then (true, true) else variance ++ if is_Tvar (repr param) then (true, true) else variance + + let tree_of_class_params params = + let tyl = tree_of_typlist true params in +@@ -890,7 +939,7 @@ + | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> + newty2 t.level + (Tvariant {(row_repr row) with row_name = None; +- row_more = newty2 (row_more row).level Tvar}) ++ row_more = newvar2 (row_more row).level}) + | _ -> t + + let prepare_expansion (t, t') = +@@ -913,9 +962,9 @@ + let has_explanation unif t3 t4 = + match t3.desc, t4.desc with + Tfield _, _ | _, Tfield _ +- | Tunivar, Tvar | Tvar, Tunivar ++ | Tunivar _, Tvar _ | Tvar _, Tunivar _ + | Tvariant _, Tvariant _ -> true +- | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) -> ++ | Tconstr (p, _, _), Tvar _ | Tvar _, Tconstr (p, _, _) -> + unif && min t3.level t4.level < Path.binding_time p + | _ -> false + +@@ -931,21 +980,21 @@ + + let explanation unif t3 t4 ppf = + match t3.desc, t4.desc with +- | Tfield _, Tvar | Tvar, Tfield _ -> ++ | Tfield _, Tvar _ | Tvar _, Tfield _ -> + fprintf ppf "@,Self type cannot escape its class" +- | Tconstr (p, tl, _), Tvar ++ | Tconstr (p, tl, _), Tvar _ + when unif && (tl = [] || t4.level < Path.binding_time p) -> + fprintf ppf + "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p +- | Tvar, Tconstr (p, tl, _) ++ | Tvar _, Tconstr (p, tl, _) + when unif && (tl = [] || t3.level < Path.binding_time p) -> + fprintf ppf + "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p +- | Tvar, Tunivar | Tunivar, Tvar -> ++ | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> + fprintf ppf "@,The universal variable %a would escape its scope" +- type_expr (if t3.desc = Tunivar then t3 else t4) ++ type_expr (if is_Tunivar t3 then t3 else t4) + | Tfield (lab, _, _, _), _ + | _, Tfield (lab, _, _, _) when lab = dummy_method -> + fprintf ppf +Index: typing/includecore.ml +=================================================================== +--- typing/includecore.ml (リビジョン 11207) ++++ typing/includecore.ml (作業コピー) +@@ -61,7 +61,7 @@ + Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> + let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in + Ctype.equal env true (ty1::params1) (row2.row_more::params2) && +- (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && ++ (match row1.row_more with {desc=Tvar _|Tconstr _} -> true | _ -> false) && + let r1, r2, pairs = + Ctype.merge_row_fields row1.row_fields row2.row_fields in + (not row2.row_closed || +@@ -91,7 +91,7 @@ + let (fields2,rest2) = Ctype.flatten_fields fi2 in + Ctype.equal env true (ty1::params1) (rest2::params2) && + let (fields1,rest1) = Ctype.flatten_fields fi1 in +- (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) && ++ (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && + let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in + miss2 = [] && + let tl1, tl2 = +@@ -251,7 +251,7 @@ + let encode_val (mut, ty) rem = + begin match mut with + Asttypes.Mutable -> Predef.type_unit +- | Asttypes.Immutable -> Btype.newgenty Tvar ++ | Asttypes.Immutable -> Btype.newgenvar () + end + ::ty::rem + +Index: typing/subst.ml +=================================================================== +--- typing/subst.ml (リビジョン 11207) ++++ typing/subst.ml (作業コピー) +@@ -71,16 +71,19 @@ + let reset_for_saving () = new_id := -1 + + let newpersty desc = +- decr new_id; { desc = desc; level = generic_level; id = !new_id } ++ decr new_id; ++ { desc = desc; level = generic_level; id = !new_id } + + (* Similar to [Ctype.nondep_type_rec]. *) + let rec typexp s ty = + let ty = repr ty in + match ty.desc with +- Tvar | Tunivar -> ++ Tvar _ | Tunivar _ -> + if s.for_saving || ty.id < 0 then ++ let desc = match ty.desc with (* Tvar _ -> Tvar None *) | d -> d in + let ty' = +- if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc ++ if s.for_saving then newpersty desc ++ else newty2 ty.level desc + in + save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty' + else ty +@@ -94,7 +97,7 @@ + let desc = ty.desc in + save_desc ty desc; + (* Make a stub *) +- let ty' = if s.for_saving then newpersty Tvar else newgenvar () in ++ let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in + ty.desc <- Tsubst ty'; + ty'.desc <- + begin match desc with +@@ -127,10 +130,10 @@ + match more.desc with + Tsubst ty -> ty + | Tconstr _ -> typexp s more +- | Tunivar | Tvar -> ++ | Tunivar _ | Tvar _ -> + save_desc more more.desc; + if s.for_saving then newpersty more.desc else +- if dup && more.desc <> Tunivar then newgenvar () else more ++ if dup && is_Tvar more then newgenty more.desc else more + | _ -> assert false + in + (* Register new type first for recursion *) +Index: typing/types.ml +=================================================================== +--- typing/types.ml (リビジョン 11207) ++++ typing/types.ml (作業コピー) +@@ -25,7 +25,7 @@ + mutable id: int } + + and type_desc = +- Tvar ++ Tvar of string option + | Tarrow of label * type_expr * type_expr * commutable + | Ttuple of type_expr list + | Tconstr of Path.t * type_expr list * abbrev_memo ref +@@ -35,7 +35,7 @@ + | Tlink of type_expr + | Tsubst of type_expr (* for copying *) + | Tvariant of row_desc +- | Tunivar ++ | Tunivar of string option + | Tpoly of type_expr * type_expr list + | Tpackage of Path.t * string list * type_expr list + +Index: ocamldoc/odoc_str.ml +=================================================================== +--- ocamldoc/odoc_str.ml (リビジョン 11207) ++++ ocamldoc/odoc_str.ml (作業コピー) +@@ -31,7 +31,7 @@ + | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2 + | Types.Ttuple _ + | Types.Tconstr _ +- | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ ++ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _ + | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false + + let raw_string_of_type_list sep type_list = +@@ -43,7 +43,7 @@ + | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2 + | Types.Tconstr _ -> + false +- | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ ++ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _ + | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false + in + let print_one_type variance t = +Index: ocamldoc/odoc_value.ml +=================================================================== +--- ocamldoc/odoc_value.ml (リビジョン 11207) ++++ ocamldoc/odoc_value.ml (作業コピー) +@@ -77,13 +77,13 @@ + | Types.Tsubst texp -> + iter texp + | Types.Tpoly (texp, _) -> iter texp +- | Types.Tvar ++ | Types.Tvar _ + | Types.Ttuple _ + | Types.Tconstr _ + | Types.Tobject _ + | Types.Tfield _ + | Types.Tnil +- | Types.Tunivar ++ | Types.Tunivar _ + | Types.Tpackage _ + | Types.Tvariant _ -> + [] +Index: ocamldoc/odoc_misc.ml +=================================================================== +--- ocamldoc/odoc_misc.ml (リビジョン 11207) ++++ ocamldoc/odoc_misc.ml (作業コピー) +@@ -478,8 +478,8 @@ + match t with + | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc + | Types.Tconstr _ +- | Types.Tvar +- | Types.Tunivar ++ | Types.Tvar _ ++ | Types.Tunivar _ + | Types.Tpoly _ + | Types.Tarrow _ + | Types.Ttuple _ +Index: bytecomp/typeopt.ml +=================================================================== +--- bytecomp/typeopt.ml (リビジョン 11207) ++++ bytecomp/typeopt.ml (作業コピー) +@@ -50,7 +50,7 @@ + + let array_element_kind env ty = + match scrape env ty with +- | Tvar | Tunivar -> ++ | Tvar _ | Tunivar _ -> + Pgenarray + | Tconstr(p, args, abbrev) -> + if Path.same p Predef.path_int || Path.same p Predef.path_char then +Index: bytecomp/translcore.ml +=================================================================== +--- bytecomp/translcore.ml (リビジョン 11207) ++++ bytecomp/translcore.ml (作業コピー) +@@ -780,12 +780,13 @@ + begin match e.exp_type.desc with + (* the following may represent a float/forward/lazy: need a + forward_tag *) +- | Tvar | Tlink _ | Tsubst _ | Tunivar ++ | Tvar _ | Tlink _ | Tsubst _ | Tunivar _ + | Tpoly(_,_) | Tfield(_,_,_,_) -> + Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) + (* the following cannot be represented as float/forward/lazy: + optimize *) +- | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _ ++ | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil ++ | Tvariant _ + -> transl_exp e + (* optimize predefined types (excepted float) *) + | Tconstr(_,_,_) -> +Index: testsuite/tests/lib-hashtbl/htbl.ml +=================================================================== +--- testsuite/tests/lib-hashtbl/htbl.ml (リビジョン 11207) ++++ testsuite/tests/lib-hashtbl/htbl.ml (作業コピー) +@@ -76,7 +76,7 @@ + struct + type key = M.key + type 'a t = (key, 'a) Hashtbl.t +- let create = Hashtbl.create ++ let create s = Hashtbl.create s + let clear = Hashtbl.clear + let copy = Hashtbl.copy + let add = Hashtbl.add +Index: toplevel/genprintval.ml +=================================================================== +--- toplevel/genprintval.ml (リビジョン 11207) ++++ toplevel/genprintval.ml (作業コピー) +@@ -180,7 +180,7 @@ + find_printer env ty obj + with Not_found -> + match (Ctype.repr ty).desc with +- | Tvar -> ++ | Tvar _ | Tunivar _ -> + Oval_stuff "" + | Tarrow(_, ty1, ty2, _) -> + Oval_stuff "" +@@ -327,8 +327,6 @@ + fatal_error "Printval.outval_of_value" + | Tpoly (ty, _) -> + tree_of_val (depth - 1) obj ty +- | Tunivar -> +- Oval_stuff "" + | Tpackage _ -> + Oval_stuff "" + end +Index: otherlibs/labltk/browser/searchid.ml +=================================================================== +--- otherlibs/labltk/browser/searchid.ml (リビジョン 11207) ++++ otherlibs/labltk/browser/searchid.ml (作業コピー) +@@ -101,7 +101,7 @@ + + let rec equal ~prefix t1 t2 = + match (repr t1).desc, (repr t2).desc with +- Tvar, Tvar -> true ++ Tvar _, Tvar _ -> true + | Tvariant row1, Tvariant row2 -> + let row1 = row_repr row1 and row2 = row_repr row2 in + let fields1 = filter_row_fields false row1.row_fields +@@ -144,7 +144,7 @@ + + let rec included ~prefix t1 t2 = + match (repr t1).desc, (repr t2).desc with +- Tvar, _ -> true ++ Tvar _, _ -> true + | Tvariant row1, Tvariant row2 -> + let row1 = row_repr row1 and row2 = row_repr row2 in + let fields1 = filter_row_fields false row1.row_fields diff --git a/experimental/garrigue/variable-names.ml b/experimental/garrigue/variable-names.ml new file mode 100644 index 00000000..f3c7771a --- /dev/null +++ b/experimental/garrigue/variable-names.ml @@ -0,0 +1,4 @@ +let f (x : < a:int; .. > as 'me1) = (x : < b:bool; .. > as 'me2);; +let f (x : < a:int; .. > as 'me1) = (x : < a:int; b:bool; .. > as 'me2);; +let f (x : [> `A of int] as 'me1) = (x : [> `B of bool] as 'me2);; +let f (x : [> `A of int] as 'me1) = (x : [`A of int | `B of 'me2] as 'me2);; diff --git a/experimental/garrigue/varunion.ml b/experimental/garrigue/varunion.ml new file mode 100644 index 00000000..30a410f2 --- /dev/null +++ b/experimental/garrigue/varunion.ml @@ -0,0 +1,435 @@ +(* cvs update -r varunion parsing typing bytecomp toplevel *) + +type t = private [> ];; +type u = private [> ] ~ [t];; +type v = [t | u];; +let f x = (x : t :> v);; + +(* bad *) +module Mix(X: sig type t = private [> ] end) + (Y: sig type t = private [> ] end) = + struct type t = [X.t | Y.t] end;; + +(* bad *) +module Mix(X: sig type t = private [> `A of int ] end) + (Y: sig type t = private [> `A of bool] ~ [X.t] end) = + struct type t = [X.t | Y.t] end;; + +(* ok *) +module Mix(X: sig type t = private [> `A of int ] end) + (Y: sig type t = private [> `A of int] ~ [X.t] end) = + struct type t = [X.t | Y.t] end;; + +(* bad *) +module Mix(X: sig type t = private [> `A of int ] end) + (Y: sig type t = private [> `B of bool] ~ [X.t] end) = + struct type t = [X.t | Y.t] end;; + +type 'a t = private [> `L of 'a] ~ [`L];; + +(* ok *) +module Mix(X: sig type t = private [> `A of int ] ~ [`B] end) + (Y: sig type t = private [> `B of bool] ~ [X.t] end) = + struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;; + +module Mix(X: sig type t = private [> `A of int ] ~ [`B] end) + (Y: sig type t = private [> `B of bool] ~ [X.t] end) = + struct + type t = [X.t | Y.t] + let which = function #X.t -> `X | #Y.t -> `Y + end;; + +module Mix(I: sig type t = private [> ] ~ [`A;`B] end) + (X: sig type t = private [> I.t | `A of int ] ~ [`B] end) + (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) = + struct + type t = [X.t | Y.t] + let which = function #X.t -> `X | #Y.t -> `Y + end;; + +(* ok *) +module M = + Mix(struct type t = [`C of char] end) + (struct type t = [`A of int | `C of char] end) + (struct type t = [`B of bool | `C of char] end);; + +(* bad *) +module M = + Mix(struct type t = [`B of bool] end) + (struct type t = [`A of int | `B of bool] end) + (struct type t = [`B of bool | `C of char] end);; + +(* ok *) +module M1 = struct type t = [`A of int | `C of char] end +module M2 = struct type t = [`B of bool | `C of char] end +module I = struct type t = [`C of char] end +module M = Mix(I)(M1)(M2) ;; + +let c = (`C 'c' : M.t) ;; + +module M(X : sig type t = private [> `A] end) = + struct let f (#X.t as x) = x end;; + +(* code generation *) +type t = private [> `A ] ~ [`B];; +match `B with #t -> 1 | `B -> 2;; + +module M : sig type t = private [> `A of int | `B] ~ [`C] end = + struct type t = [`A of int | `B | `D of bool] end;; +let f = function (`C | #M.t) -> 1+1 ;; +let f = function (`A _ | `B #M.t) -> 1+1 ;; + +(* expression *) +module Mix(X:sig type t = private [> ] val show: t -> string end) + (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) = + struct + type t = [X.t | Y.t] + let show : t -> string = function + #X.t as x -> X.show x + | #Y.t as y -> Y.show y + end;; + +module EStr = struct + type t = [`Str of string] + let show (`Str s) = s +end +module EInt = struct + type t = [`Int of int] + let show (`Int i) = string_of_int i +end +module M = Mix(EStr)(EInt);; + +module type T = sig type t = private [> ] val show: t -> string end +module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) : + T with type t = [X.t | Y.t] = + struct + type t = [X.t | Y.t] + let show = function + #X.t as x -> X.show x + | #Y.t as y -> Y.show y + end;; +module M = Mix(EStr)(EInt);; + +(* deep *) +module M : sig type t = private [> `A] end = struct type t = [`A] end +module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;; + +(* bad *) +type t = private [> ] +type u = private [> `A of int] ~ [t] ;; + +(* ok *) +type t = private [> `A of int] +type u = private [> `A of int] ~ [t] ;; + +module F(X: sig + type t = private [> ] ~ [`A;`B;`C;`D] + type u = private [> `A|`B|`C] ~ [t; `D] +end) : sig type v = private [< X.t | X.u | `D] end = struct + open X + let f = function #u -> 1 | #t -> 2 | `D -> 3 + let g = function #u|#t|`D -> 2 + type v = [t|u|`D] +end + +(* ok *) +module M = struct type t = private [> `A] end;; +module M' : sig type t = private [> ] ~ [`A] end = M;; + +(* ok *) +module type T = sig type t = private [> ] ~ [`A] end;; +module type T' = T with type t = private [> `A];; + +(* ok *) +type t = private [> ] ~ [`A] +let f = function `A x -> x | #t -> 0 +type t' = private [< `A of int | t];; + +(* should be ok *) +module F(X:sig end) : + sig type t = private [> ] type u = private [> ] ~ [t] end = + struct type t = [ `A] type u = [`B] end +module M = F(String) +let f = function #M.t -> 1 | #M.u -> 2 +let f = function #M.t -> 1 | _ -> 2 +type t = [M.t | M.u] +let f = function #t -> 1 | _ -> 2;; +module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) = + struct let f = function #X.t -> 1 | _ -> 2 end;; +module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;; +module M1 = G(struct type t = M.t type u = M.u end) ;; +(* bad *) +let f = function #F(String).t -> 1 | _ -> 2;; +type t = [F(String).t | M.u] +let f = function #t -> 1 | _ -> 2;; +module N : sig type t = private [> ] end = + struct type t = [F(String).t | M.u] end;; + +(* compatibility improvement *) +type a = [`A of int | `B] +type b = [`A of bool | `B] +type c = private [> ] ~ [a;b] +let f = function #c -> 1 | `A x -> truncate x +type d = private [> ] ~ [a] +let g = function #d -> 1 | `A x -> truncate x;; + + +(* Expression Problem: functorial form *) + +type num = [ `Num of int ] + +module type Exp = sig + type t = private [> num] + val eval : t -> t + val show : t -> string +end + +module Num(X : Exp) = struct + type t = num + let eval (`Num _ as x) : X.t = x + let show (`Num n) = string_of_int n +end + +type 'a add = [ `Add of 'a * 'a ] + +module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct + type t = X.t add + let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")" + let eval (`Add(e1, e2) : t) = + let e1 = X.eval e1 and e2 = X.eval e2 in + match e1, e2 with + `Num n1, `Num n2 -> `Num (n1+n2) + | `Num 0, e | e, `Num 0 -> e + | e12 -> `Add e12 +end + +type 'a mul = [`Mul of 'a * 'a] + +module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct + type t = X.t mul + let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")" + let eval (`Mul(e1, e2) : t) = + let e1 = X.eval e1 and e2 = X.eval e2 in + match e1, e2 with + `Num n1, `Num n2 -> `Num (n1*n2) + | `Num 0, e | e, `Num 0 -> `Num 0 + | `Num 1, e | e, `Num 1 -> e + | e12 -> `Mul e12 +end + +module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct + module type S = + sig + type t = private [> ] ~ [ X.t ] + val eval : t -> Y.t + val show : t -> string + end +end + +module Dummy = struct type t = [`Dummy] end + +module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) = + struct + type t = [E1.t | E2.t] + let eval = function + #E1.t as x -> E1.eval x + | #E2.t as x -> E2.eval x + let show = function + #E1.t as x -> E1.show x + | #E2.t as x -> E2.show x + end + +module rec EAdd : (Exp with type t = [num | EAdd.t add]) = + Mix(EAdd)(Num(EAdd))(Add(EAdd)) + +(* A bit heavy: one must pass E to everybody *) +module rec E : Exp with type t = [num | E.t add | E.t mul] = + Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)) + +let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1)) + +(* Alternatives *) +(* Direct approach, no need of Mix *) +module rec E : (Exp with type t = [num | E.t add | E.t mul]) = + struct + module E1 = Num(E) + module E2 = Add(E) + module E3 = Mul(E) + type t = E.t + let show = function + | #num as x -> E1.show x + | #add as x -> E2.show x + | #mul as x -> E3.show x + let eval = function + | #num as x -> E1.eval x + | #add as x -> E2.eval x + | #mul as x -> E3.eval x + end + +(* Do functor applications in Mix *) +module type T = sig type t = private [> ] end +module type Tnum = sig type t = private [> num] end + +module Ext(E : Tnum) = struct + module type S = functor (Y : Exp with type t = E.t) -> + sig + type t = private [> num] + val eval : t -> Y.t + val show : t -> string + end +end + +module Ext'(E : Tnum)(X : T) = struct + module type S = functor (Y : Exp with type t = E.t) -> + sig + type t = private [> ] ~ [ X.t ] + val eval : t -> Y.t + val show : t -> string + end +end + +module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) = + struct + module E1 = F1(E) + module E2 = F2(E) + type t = [E1.t | E2.t] + let eval = function + #E1.t as x -> E1.eval x + | #E2.t as x -> E2.eval x + let show = function + #E1.t as x -> E1.show x + | #E2.t as x -> E2.show x + end + +module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) + (E' : Exp with type t = E.t) = + Mix(E)(F1)(F2) + +module rec EAdd : (Exp with type t = [num | EAdd.t add]) = + Mix(EAdd)(Num)(Add) + +module rec EMul : (Exp with type t = [num | EMul.t mul]) = + Mix(EMul)(Num)(Mul) + +module rec E : (Exp with type t = [num | E.t add | E.t mul]) = + Mix(E)(Join(E)(Num)(Add))(Mul) + +(* Linear extension by the end: not so nice *) +module LExt(X : T) = struct + module type S = + sig + type t + val eval : t -> X.t + val show : t -> string + end +end +module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) = + struct + type t = [num | X.t] + let show = function + `Num n -> string_of_int n + | #X.t as x -> X.show x + let eval = function + #num as x -> x + | #X.t as x -> X.eval x + end +module LAdd(E : Exp with type t = private [> num | 'a add] as 'a) + (X : LExt(E).S with type t = private [> ] ~ [add]) = + struct + type t = [E.t add | X.t] + let show = function + `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")" + | #X.t as x -> X.show x + let eval = function + `Add(e1,e2) -> + let e1 = E.eval e1 and e2 = E.eval e2 in + begin match e1, e2 with + `Num n1, `Num n2 -> `Num (n1+n2) + | `Num 0, e | e, `Num 0 -> e + | e12 -> `Add e12 + end + | #X.t as x -> X.eval x + end +module LEnd = struct + type t = [`Dummy] + let show `Dummy = "" + let eval `Dummy = `Dummy +end +module rec L : Exp with type t = [num | L.t add | `Dummy] = + LAdd(L)(LNum(L)(LEnd)) + +(* Back to first form, but add map *) + +module Num(X : Exp) = struct + type t = num + let map f x = x + let eval1 (`Num _ as x) : X.t = x + let show (`Num n) = string_of_int n +end + +module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct + type t = X.t add + let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")" + let map f (`Add(e1, e2) : t) = `Add(f e1, f e2) + let eval1 (`Add(e1, e2) as e : t) = + match e1, e2 with + `Num n1, `Num n2 -> `Num (n1+n2) + | `Num 0, e | e, `Num 0 -> e + | _ -> e +end + +module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct + type t = X.t mul + let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")" + let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2) + let eval1 (`Mul(e1, e2) as e : t) = + match e1, e2 with + `Num n1, `Num n2 -> `Num (n1*n2) + | `Num 0, e | e, `Num 0 -> `Num 0 + | `Num 1, e | e, `Num 1 -> e + | _ -> e +end + +module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct + module type S = + sig + type t = private [> ] ~ [ X.t ] + val map : (Y.t -> Y.t) -> t -> t + val eval1 : t -> Y.t + val show : t -> string + end +end + +module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) = + struct + type t = [E1.t | E2.t] + let map f = function + #E1.t as x -> (E1.map f x : E1.t :> t) + | #E2.t as x -> (E2.map f x : E2.t :> t) + let eval1 = function + #E1.t as x -> E1.eval1 x + | #E2.t as x -> E2.eval1 x + let show = function + #E1.t as x -> E1.show x + | #E2.t as x -> E2.show x + end + +module type ET = sig + type t + val map : (t -> t) -> t -> t + val eval1 : t -> t + val show : t -> string +end + +module Fin(E : ET) = struct + include E + let rec eval e = eval1 (map eval e) +end + +module rec EAdd : (Exp with type t = [num | EAdd.t add]) = + Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd))) + +module rec E : Exp with type t = [num | E.t add | E.t mul] = + Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))) + +let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1)) diff --git a/experimental/garrigue/with-module-type.diffs b/experimental/garrigue/with-module-type.diffs new file mode 100644 index 00000000..c955b1f8 --- /dev/null +++ b/experimental/garrigue/with-module-type.diffs @@ -0,0 +1,182 @@ +Index: parsing/parser.mly +=================================================================== +--- parsing/parser.mly (revision 12005) ++++ parsing/parser.mly (working copy) +@@ -1504,6 +1504,10 @@ + { ($2, Pwith_module $4) } + | MODULE mod_longident COLONEQUAL mod_ext_longident + { ($2, Pwith_modsubst $4) } ++ | MODULE TYPE mod_longident EQUAL module_type ++ { ($3, Pwith_modtype $5) } ++ | MODULE TYPE mod_longident COLONEQUAL module_type ++ { ($3, Pwith_modtypesubst $5) } + ; + with_type_binder: + EQUAL { Public } +Index: parsing/parsetree.mli +=================================================================== +--- parsing/parsetree.mli (revision 12005) ++++ parsing/parsetree.mli (working copy) +@@ -239,6 +239,8 @@ + | Pwith_module of Longident.t + | Pwith_typesubst of type_declaration + | Pwith_modsubst of Longident.t ++ | Pwith_modtype of module_type ++ | Pwith_modtypesubst of module_type + + (* Value expressions for the module language *) + +Index: parsing/printast.ml +=================================================================== +--- parsing/printast.ml (revision 12005) ++++ parsing/printast.ml (working copy) +@@ -575,6 +575,12 @@ + 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_modtype (mty) -> ++ line i ppf "Pwith_modtype\n"; ++ module_type (i+1) ppf mty; ++ | Pwith_modtypesubst (mty) -> ++ line i ppf "Pwith_modtype\n"; ++ module_type (i+1) ppf mty; + + and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; +Index: typing/typemod.ml +=================================================================== +--- typing/typemod.ml (revision 12005) ++++ typing/typemod.ml (working copy) +@@ -74,6 +74,8 @@ + : (Env.t -> Parsetree.module_expr -> module_type) ref + = ref (fun env m -> assert false) + ++let transl_modtype_fwd = ref (fun env m -> assert false) ++ + (* Merge one "with" constraint in a signature *) + + let rec add_rec_types env = function +@@ -163,6 +165,19 @@ + ignore(Includemod.modtypes env newmty mty); + real_id := Some id; + make_next_first rs rem ++ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty) ++ when Ident.name id = s -> ++ let mty = !transl_modtype_fwd initial_env pmty in ++ let mtd' = Tmodtype_manifest mty in ++ Includemod.modtype_declarations env id mtd' mtd; ++ Tsig_modtype(id, mtd') :: rem ++ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty) ++ when Ident.name id = s -> ++ let mty = !transl_modtype_fwd initial_env pmty in ++ let mtd' = Tmodtype_manifest mty in ++ Includemod.modtype_declarations env id mtd' mtd; ++ real_id := Some id; ++ rem + | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _) + when Ident.name id = s -> + let newsg = merge env (extract_sig env loc mty) namelist None in +@@ -200,6 +215,12 @@ + let (path, _) = Typetexp.find_module initial_env loc lid in + let sub = Subst.add_module id path Subst.identity in + Subst.signature sub sg ++ | [s], Pwith_modtypesubst pmty -> ++ let id = ++ match !real_id with None -> assert false | Some id -> id in ++ let mty = !transl_modtype_fwd initial_env pmty in ++ let sub = Subst.add_modtype id mty Subst.identity in ++ Subst.signature sub sg + | _ -> + sg + with Includemod.Error explanation -> +@@ -499,6 +520,8 @@ + check_recmod_typedecls env2 sdecls dcl2; + (dcl2, env2) + ++let () = transl_modtype_fwd := transl_modtype ++ + (* Try to convert a module expression to a module path. *) + + exception Not_a_path +Index: typing/includemod.ml +=================================================================== +--- typing/includemod.ml (revision 12005) ++++ typing/includemod.ml (working copy) +@@ -326,10 +326,10 @@ + + (* Hide the context and substitution parameters to the outside world *) + +-let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2 +-let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 +-let type_declarations env id decl1 decl2 = +- type_declarations env [] Subst.identity id decl1 decl2 ++let modtypes env = modtypes env [] Subst.identity ++let signatures env = signatures env [] Subst.identity ++let type_declarations env = type_declarations env [] Subst.identity ++let modtype_declarations env = modtype_infos env [] Subst.identity + + (* Error report *) + +Index: typing/includemod.mli +=================================================================== +--- typing/includemod.mli (revision 12005) ++++ typing/includemod.mli (working copy) +@@ -23,6 +23,8 @@ + val compunit: string -> signature -> string -> signature -> module_coercion + val type_declarations: + Env.t -> Ident.t -> type_declaration -> type_declaration -> unit ++val modtype_declarations: ++ Env.t -> Ident.t -> modtype_declaration -> modtype_declaration -> unit + + type symptom = + Missing_field of Ident.t +Index: testsuite/tests/typing-modules/Test.ml.reference +=================================================================== +--- testsuite/tests/typing-modules/Test.ml.reference (revision 12005) ++++ testsuite/tests/typing-modules/Test.ml.reference (working copy) +@@ -6,4 +6,12 @@ + # type -'a t + class type c = object method m : [ `A ] t end + # module M : sig val v : (#c as 'a) -> 'a end ++# module type S = sig module type T module F : functor (X : T) -> T end ++# module type T0 = sig type t end ++# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end ++# module type S2 = sig module F : functor (X : T0) -> T0 end ++# module type S3 = ++ sig ++ module F : functor (X : sig type t = int end) -> sig type t = int end ++ end + # +Index: testsuite/tests/typing-modules/Test.ml.principal.reference +=================================================================== +--- testsuite/tests/typing-modules/Test.ml.principal.reference (revision 12005) ++++ testsuite/tests/typing-modules/Test.ml.principal.reference (working copy) +@@ -6,4 +6,12 @@ + # type -'a t + class type c = object method m : [ `A ] t end + # module M : sig val v : (#c as 'a) -> 'a end ++# module type S = sig module type T module F : functor (X : T) -> T end ++# module type T0 = sig type t end ++# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end ++# module type S2 = sig module F : functor (X : T0) -> T0 end ++# module type S3 = ++ sig ++ module F : functor (X : sig type t = int end) -> sig type t = int end ++ end + # +Index: testsuite/tests/typing-modules/Test.ml +=================================================================== +--- testsuite/tests/typing-modules/Test.ml (revision 12005) ++++ testsuite/tests/typing-modules/Test.ml (working copy) +@@ -9,3 +9,11 @@ + class type c = object method m : [ `A ] t end;; + module M : sig val v : (#c as 'a) -> 'a end = + struct let v x = ignore (x :> c); x end;; ++ ++(* with module type *) ++ ++module type S = sig module type T module F(X:T) : T end;; ++module type T0 = sig type t end;; ++module type S1 = S with module type T = T0;; ++module type S2 = S with module type T := T0;; ++module type S3 = S with module type T := sig type t = int end;; diff --git a/lex/.cvsignore b/lex/.cvsignore deleted file mode 100644 index 9f4f308d..00000000 --- a/lex/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -parser.ml -parser.mli -lexer.ml -ocamllex -ocamllex.opt -parser.output diff --git a/lex/.depend b/lex/.depend index b51dbd3b..b0df0b87 100644 --- a/lex/.depend +++ b/lex/.depend @@ -1,34 +1,34 @@ -common.cmi: syntax.cmi lexgen.cmi -compact.cmi: lexgen.cmi -cset.cmi: -lexer.cmi: parser.cmi -lexgen.cmi: syntax.cmi -output.cmi: syntax.cmi lexgen.cmi compact.cmi common.cmi -outputbis.cmi: syntax.cmi lexgen.cmi common.cmi -parser.cmi: syntax.cmi -syntax.cmi: cset.cmi -table.cmi: -common.cmo: syntax.cmi lexgen.cmi common.cmi -common.cmx: syntax.cmx lexgen.cmx common.cmi -compact.cmo: table.cmi lexgen.cmi compact.cmi -compact.cmx: table.cmx lexgen.cmx compact.cmi -cset.cmo: cset.cmi -cset.cmx: cset.cmi -lexer.cmo: syntax.cmi parser.cmi lexer.cmi -lexer.cmx: syntax.cmx parser.cmx lexer.cmi -lexgen.cmo: table.cmi syntax.cmi cset.cmi lexgen.cmi -lexgen.cmx: table.cmx syntax.cmx cset.cmx lexgen.cmi -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 -parser.cmo: syntax.cmi cset.cmi parser.cmi -parser.cmx: syntax.cmx cset.cmx parser.cmi -syntax.cmo: cset.cmi syntax.cmi -syntax.cmx: cset.cmx syntax.cmi -table.cmo: table.cmi -table.cmx: table.cmi +common.cmi : syntax.cmi lexgen.cmi +compact.cmi : lexgen.cmi +cset.cmi : +lexer.cmi : parser.cmi +lexgen.cmi : syntax.cmi +output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi +outputbis.cmi : syntax.cmi lexgen.cmi common.cmi +parser.cmi : syntax.cmi +syntax.cmi : cset.cmi +table.cmi : +common.cmo : syntax.cmi lexgen.cmi common.cmi +common.cmx : syntax.cmx lexgen.cmx common.cmi +compact.cmo : table.cmi lexgen.cmi compact.cmi +compact.cmx : table.cmx lexgen.cmx compact.cmi +cset.cmo : cset.cmi +cset.cmx : cset.cmi +lexer.cmo : syntax.cmi parser.cmi lexer.cmi +lexer.cmx : syntax.cmx parser.cmx lexer.cmi +lexgen.cmo : table.cmi syntax.cmi cset.cmi lexgen.cmi +lexgen.cmx : table.cmx syntax.cmx cset.cmx lexgen.cmi +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 +parser.cmo : syntax.cmi cset.cmi parser.cmi +parser.cmx : syntax.cmx cset.cmx parser.cmi +syntax.cmo : cset.cmi syntax.cmi +syntax.cmx : cset.cmx syntax.cmi +table.cmo : table.cmi +table.cmx : table.cmi diff --git a/lex/.ignore b/lex/.ignore new file mode 100644 index 00000000..9f4f308d --- /dev/null +++ b/lex/.ignore @@ -0,0 +1,6 @@ +parser.ml +parser.mli +lexer.ml +ocamllex +ocamllex.opt +parser.output diff --git a/lex/Makefile b/lex/Makefile index f190ed89..d73939a3 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # diff --git a/lex/Makefile.nt b/lex/Makefile.nt index cb1ef94a..8443c575 100644 --- a/lex/Makefile.nt +++ b/lex/Makefile.nt @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # diff --git a/lex/common.ml b/lex/common.ml index cacea62d..5638185d 100644 --- a/lex/common.ml +++ b/lex/common.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, projet Moscova, *) (* INRIA Rocquencourt *) diff --git a/lex/common.mli b/lex/common.mli index e5742b45..f85baa01 100644 --- a/lex/common.mli +++ b/lex/common.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/lex/compact.ml b/lex/compact.ml index abbf5a50..72cfd9e7 100644 --- a/lex/compact.ml +++ b/lex/compact.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/compact.mli b/lex/compact.mli index 18363c3d..6e48df00 100644 --- a/lex/compact.mli +++ b/lex/compact.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/cset.ml b/lex/cset.ml index c4594540..ce77044b 100644 --- a/lex/cset.ml +++ b/lex/cset.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, Jerome Vouillon projet Cristal, *) (* INRIA Rocquencourt *) diff --git a/lex/cset.mli b/lex/cset.mli index 53b58995..b30c3b67 100644 --- a/lex/cset.mli +++ b/lex/cset.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, Jerome Vouillon projet Cristal, *) (* INRIA Rocquencourt *) diff --git a/lex/lexer.mli b/lex/lexer.mli index be34674e..5097d309 100644 --- a/lex/lexer.mli +++ b/lex/lexer.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/lexer.mll b/lex/lexer.mll index b7280428..b99dddf9 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 775e78b0..37720be6 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, *) (* Luc Maranget, projet Moscova, *) diff --git a/lex/lexgen.mli b/lex/lexgen.mli index 5136f8f2..155b9e45 100644 --- a/lex/lexgen.mli +++ b/lex/lexgen.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/main.ml b/lex/main.ml index 57b40490..28f1e55e 100644 --- a/lex/main.ml +++ b/lex/main.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -24,7 +24,7 @@ let output_name = ref None let usage = "usage: ocamlex [options] sourcefile" let print_version_string () = - print_string "The Objective Caml lexer generator, version "; + print_string "The OCaml lexer generator, version "; print_string Sys.ocaml_version ; print_newline(); exit 0 diff --git a/lex/output.ml b/lex/output.ml index 5ca403b5..377c00a2 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/output.mli b/lex/output.mli index 85f89b30..5eae1031 100644 --- a/lex/output.mli +++ b/lex/output.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 6d5e77c3..7eac3544 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/outputbis.mli b/lex/outputbis.mli index 76f00672..df6bf960 100644 --- a/lex/outputbis.mli +++ b/lex/outputbis.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget projet Moscova INRIA Rocquencourt *) (* *) diff --git a/lex/parser.mly b/lex/parser.mly index 9bc0906a..c36d8e02 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ diff --git a/lex/syntax.ml b/lex/syntax.ml index d1daa02d..746a99a2 100644 --- a/lex/syntax.ml +++ b/lex/syntax.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/syntax.mli b/lex/syntax.mli index 4864b50e..d61fdb22 100644 --- a/lex/syntax.mli +++ b/lex/syntax.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/lex/table.ml b/lex/table.ml index 402f52be..fb5a6128 100644 --- a/lex/table.ml +++ b/lex/table.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/lex/table.mli b/lex/table.mli index b88d7d34..8d9938cb 100644 --- a/lex/table.mli +++ b/lex/table.mli @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Luc Maranget, projet Moscova, INRIA Rocquencourt *) (* *) diff --git a/man/Makefile b/man/Makefile index 4753c202..4c0cb819 100644 --- a/man/Makefile +++ b/man/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # @@ -20,3 +20,4 @@ install: for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT) echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT) + echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' > $(DIR)/ocamloptp.$(MANEXT) diff --git a/man/ocaml.m b/man/ocaml.m index f8ca062d..c230038c 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -1,9 +1,21 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAML 1 .SH NAME -ocaml \- The Objective Caml interactive toplevel +ocaml \- The OCaml interactive toplevel .SH SYNOPSIS .B ocaml @@ -20,9 +32,9 @@ ocaml \- The Objective Caml interactive toplevel The .BR ocaml (1) -command is the toplevel system for Objective Caml, -that permits interactive use of the Objective Caml system through a -read-eval-print loop. In this mode, the system repeatedly reads Caml +command is the toplevel system for OCaml, +that permits interactive use of the OCaml system through a +read-eval-print loop. In this mode, the system repeatedly reads OCaml phrases from the input, then typechecks, compiles and evaluates them, then prints the inferred type and result value, if any. The system prints a # (sharp) prompt before reading each phrase. @@ -102,6 +114,14 @@ applications, and parameter order becomes strict. .B \-noprompt Do not display any prompt when waiting for input. .TP +.B \-nopromptcont +Do not display the secondary prompt when waiting for continuation lines in +multi-line inputs. This should be used e.g. when running +.BR ocaml (1) +in an +.BR emacs (1) +window. +.TP .B \-nostdlib Do not include the standard library directory in the list of directories searched for source and compiled files. @@ -178,5 +198,5 @@ and look up its capabilities in the terminal database. .SH SEE ALSO .BR ocamlc (1), \ ocamlopt (1), \ ocamlrun (1). .br -.IR The\ Objective\ Caml\ user's\ manual , +.IR The\ OCaml\ user's\ manual , chapter "The toplevel system". diff --git a/man/ocamlc.m b/man/ocamlc.m index 20cd06ef..c26d29ca 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -1,9 +1,21 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLC 1 .SH NAME -ocamlc \- The Objective Caml bytecode compiler +ocamlc \- The OCaml bytecode compiler .SH SYNOPSIS .B ocamlc @@ -20,9 +32,9 @@ ocamlc \- The Objective Caml bytecode compiler .SH DESCRIPTION -The Objective Caml bytecode compiler +The OCaml bytecode compiler .BR ocamlc (1) -compiles Caml source files to bytecode object files and links +compiles OCaml source files to bytecode object files and links these object files to produce standalone bytecode executable files. These executable files are then run by the bytecode interpreter .BR ocamlrun (1). @@ -78,7 +90,7 @@ the implementation Arguments ending in .cmo are taken to be compiled object bytecode. These files are linked together, along with the object files obtained -by compiling .ml arguments (if any), and the Caml Light standard +by compiling .ml arguments (if any), and the OCaml standard library, to produce a standalone executable program. The order in which .cmo and.ml arguments are presented on the command line is relevant: compilation units are initialized in that order at @@ -117,14 +129,14 @@ below). Arguments ending in .so are assumed to be C shared libraries (DLLs). During linking, they are -searched for external C functions referenced from the Caml code, +searched for external C functions referenced from the OCaml code, and their names are written in the generated bytecode executable. The run-time system .BR ocamlrun (1) then loads them dynamically at program start-up time. The output of the linking phase is a file containing compiled bytecode -that can be executed by the Objective Caml bytecode interpreter: +that can be executed by the OCaml bytecode interpreter: the command .BR ocamlrun (1). If @@ -158,7 +170,7 @@ Thus, it behaves exactly like .BR ocamlc , but compiles faster. .B ocamlc.opt -may not be available in all installations of Objective Caml. +may not be available in all installations of OCaml. .SH OPTIONS @@ -196,6 +208,11 @@ 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. +.TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no @@ -242,7 +259,7 @@ and the bytecode for the program. The resulting file is larger, but it can be executed directly, even if the .BR ocamlrun (1) command is not -installed. Moreover, the "custom runtime" mode enables linking Caml +installed. Moreover, the "custom runtime" mode enables linking OCaml code with user-defined C functions. Never use the @@ -389,10 +406,9 @@ specify the name of the output file produced. .TP .B \-output\-obj Cause the linker to produce a C object file instead of a bytecode -executable file. This is useful to wrap Caml code as a C library, -callable from any C program. The name of the output object file is -.B camlprog.o -by default; it can be set with the +executable file. This is useful to wrap OCaml code as a C library, +callable from any C program. The name of the output object file +must be set with the .B \-o option. This option can also be used to produce a C source file (.c extension) or @@ -444,10 +460,23 @@ only recursive types where the recursion goes through an object type are supported. Note that once you have created an interface using this flag, you must use it again for all dependencies. .TP +.BI \-runtime\-variant \ suffix +Add +.I suffix +to the name of the runtime library that will be used by the program. +If OCaml was configured with option +.BR \-with\-debug\-runtime , +then the +.B d +suffix is supported and gives a debug version of the runtime. +.TP +.B \-strict\-sequence +The left-hand part of a sequence must have type unit. +.TP .B \-thread Compile or link multithreaded programs, in combination with the system "threads" library described in -.IR The\ Objective\ Caml\ user's\ manual . +.IR The\ OCaml\ user's\ manual . .TP .B \-unsafe Turn bound checking off for array and string accesses (the @@ -476,14 +505,14 @@ invocations of the C compiler and linker in .B \-custom mode. Useful to debug C library problems. .TP -.BR \-vnum or \-version +.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\ Objective\ Caml\ user's\ manual . +.IR The\ OCaml\ user's\ manual . .TP .BI \-w \ warning\-list Enable, disable, or mark as errors the warnings specified by the argument @@ -518,6 +547,27 @@ between them. A warning specifier is one of the following: \ \ Enable and mark warning number .IR num . +.BI + num1 .. num2 +\ \ Enable all warnings between +.I num1 +and +.I num2 +(inclusive). + +.BI \- num1 .. num2 +\ \ Disable all warnings between +.I num1 +and +.I num2 +(inclusive). + +.BI @ num1 .. num2 +\ \ Enable and mark all warnings between +.I num1 +and +.I num2 +(inclusive). + .BI + letter \ \ Enable the set of warnings corresponding to .IR letter . @@ -565,7 +615,7 @@ function type and is ignored. \ \ \ Label omitted in function application. 7 -\ \ \ Some methods are overridden in the class where they are defined. +\ \ \ Method overridden without using the "override" keyword 8 \ \ \ Partial match: missing cases in pattern-matching. @@ -642,7 +692,6 @@ pattern. 29 \ \ A non-escaped end-of-line was found in a string constant. This may - cause portability problems between Unix and Windows. The letters stand for the following sets of warnings. Any letter not @@ -663,6 +712,9 @@ mentioned here corresponds to the empty set. .B F \ 5 +.B K +\ 32, 33, 34, 35, 36, 37 + .B L \ 6 @@ -685,7 +737,7 @@ mentioned here corresponds to the empty set. \ 13 .B X -\ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 +\ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 30 .B Y \ 26 @@ -695,7 +747,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-9\-27\-28\-29 . +.BR \-w\ +a\-4\-6\-9\-27\-29\-32..37 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. @@ -717,14 +769,14 @@ sign (or a lowercase letter) turns them back into warnings, and a .B @ sign both enables and marks the corresponding warnings. -Note: it is not recommended to use warning sets (i.e. letters) as -arguments to +Note: it is not recommended to use the .B \-warn\-error -in production code, because this can break your build when future versions -of OCaml add some new warnings. +option in production code, because it will almost certainly prevent +compiling your program with later versions of OCaml when they add new +warnings. The default setting is -.B \-warn\-error\ +a +.B \-warn\-error\ -a (none of the warnings is treated as an error). .TP .B \-where @@ -741,5 +793,5 @@ Display a short usage summary and exit. .SH SEE ALSO .BR ocamlopt (1), \ ocamlrun (1), \ ocaml (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Batch compilation". diff --git a/man/ocamlcp.m b/man/ocamlcp.m index d3559ad3..10077e12 100644 --- a/man/ocamlcp.m +++ b/man/ocamlcp.m @@ -1,9 +1,21 @@ -\" $Id$ - -.TH OCAMLCP 1 +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" +.TH "OCAMLCP" 1 .SH NAME -ocamlcp \- The Objective Caml profiling compiler +ocamlcp, ocamloptp \- The OCaml profiling compilers .SH SYNOPSIS .B ocamlcp @@ -11,36 +23,62 @@ ocamlcp \- The Objective Caml profiling compiler .I ocamlc options ] [ -.BI \-p \ flags +.BI \-P \ flags +] +.I filename ... + +.B ocamloptp +[ +.I ocamlopt options +] +[ +.BI \-P \ flags ] .I filename ... .SH DESCRIPTION The .B ocamlcp -command is a front-end to +and +.B ocamloptp +commands are front-ends to .BR ocamlc (1) -that instruments the source code, adding code to record how many times -functions are called, branches of conditionals are taken, ... +and +.BR ocamlopt (1) +that instrument the source code, adding code to record how many times +functions are called, branches of conditionals are taken, etc. Execution of instrumented code produces an execution profile in the file ocamlprof.dump, which can be read using .BR ocamlprof (1). .B ocamlcp accepts the same arguments and options as -.BR ocamlc (1). +.BR ocamlc (1) +and +.B ocamloptp +accepts the same arguments and options as +.BR ocamlopt (1). +There is only one exception: in both cases, the +.B \-pp +option is not supported. If you need to preprocess your source files, +you will have to do it separately before calling +.B ocamlcp +or +.BR ocamloptp . .SH OPTIONS In addition to the .BR ocamlc (1) +or +.BR ocamlopt (1) options, .B ocamlcp -accepts the following option controlling the amount of profiling -information: -.TP -.BI \-p \ letters -The +and +.B ocamloptp +accept one option to control the kind of profiling information, the +.BI \-P \ letters +option. The .I letters indicate which parts of the program should be profiled: .TP @@ -72,28 +110,32 @@ branch of an exception catcher .PP For instance, compiling with -.B ocamlcp\ \-pfilm +.B ocamlcp \-P film profiles function calls, .BR if \ ... \ then \ ... \ else \ ..., loops, and pattern matching. Calling .BR ocamlcp (1) +or +.BR ocamloptp (1) without the -.B \-p +.B \-P option defaults to -.B \-p\ fm +.BR \-P\ fm , meaning that only function calls and pattern matching are profiled. -Note: due to the implementation of streams and stream patterns as -syntactic sugar, it is hard to predict what parts of stream expressions -and patterns will be profiled by a given flag. To profile a program with -streams, we recommend using -.BR ocamlcp\ \-p\ a . +Note: for compatibility with previous versions, +.BR ocamlcp (1) +also accepts the option +.B \-p +with the same argument and meaning as +.BR \-P . .SH SEE ALSO .BR ocamlc (1), +.BR ocamlopt (1), .BR ocamlprof (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Profiling". diff --git a/man/ocamldebug.m b/man/ocamldebug.m index d527fe87..0eceeba3 100644 --- a/man/ocamldebug.m +++ b/man/ocamldebug.m @@ -1,15 +1,27 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* 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. * +.\"* * +.\"*********************************************************************** +.\" +.\" $Id$ +.\" .TH OCAMLDEBUG 1 .SH NAME -ocamldebug \- the Objective Caml source-level replay debugger. +ocamldebug \- the OCaml source-level replay debugger. .SH SYNOPSIS .B ocamldebug .RI [\ options \ ]\ program \ [\ arguments \ ] .SH DESCRIPTION .B ocamldebug -is the Objective Caml source-level replay debugger. +is the OCaml source-level replay debugger. Before the debugger can be used, the program must be compiled and linked with the @@ -46,7 +58,7 @@ command.) .TP .B \-emacs Tell the debugger it is executed under Emacs. (See -.I "The Objective Caml user's manual" +.I "The OCaml user's manual" for information on how to run the debugger under Emacs.) .TP .BI \-I \ directory @@ -64,7 +76,7 @@ for communicating with the debugged program. See the description of the command .B set\ socket in -.I "The Objective Caml user's manual" +.I "The OCaml user's manual" for the format of .IR socket . .TP @@ -79,7 +91,7 @@ Display a short usage summary and exit. .SH SEE ALSO .BR ocamlc (1) .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "The debugger". .SH AUTHOR This manual page was written by Sven LUTHER , diff --git a/man/ocamldep.m b/man/ocamldep.m index 521e41bb..be1e7348 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -1,9 +1,21 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLDEP 1 .SH NAME -ocamldep \- Dependency generator for Objective Caml +ocamldep \- Dependency generator for OCaml .SH SYNOPSIS .B ocamldep @@ -16,7 +28,7 @@ ocamldep \- Dependency generator for Objective Caml The .BR ocamldep (1) -command scans a set of Objective Caml source files +command scans a set of OCaml source files (.ml and .mli files) for references to external compilation units, and outputs dependency lines in a format suitable for the .BR make (1) @@ -117,5 +129,5 @@ Display a short usage summary and exit. .BR ocamlc (1), .BR ocamlopt (1). .br -.IR The\ Objective\ Caml\ user's\ manual , +.IR The\ OCaml\ user's\ manual , chapter "Dependency generator". diff --git a/man/ocamldoc.m b/man/ocamldoc.m index 5c217cfa..32d6aae1 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -1,5 +1,17 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* OCaml * +.\"* * +.\"* Maxence Guesdon, projet Cristal, INRIA Rocquencourt * +.\"* * +.\"* Copyright 2004 Institut National de 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$ +.\" .TH OCAMLDOC 1 \" .de Sh \" Subsection heading @@ -12,7 +24,7 @@ \" .. .SH NAME -ocamldoc \- The Objective Caml documentation generator +ocamldoc \- The OCaml documentation generator .SH SYNOPSIS @@ -24,15 +36,18 @@ ocamldoc \- The Objective Caml documentation generator .SH DESCRIPTION -The Objective Caml documentation generator +The OCaml documentation generator .BR ocamldoc (1) generates documentation from special comments embedded in source files. The -comments used by OCamldoc are of the form +comments used by +.B ocamldoc +are of the form .I (** ... *) and follow the format described in the -.IR "The Objective Caml user's manual" . +.IR "The OCaml user's manual" . -OCamldoc can produce documentation in various formats: HTML, LaTeX, TeXinfo, +.B ocamldoc +can produce documentation in various formats: HTML, LaTeX, TeXinfo, Unix man pages, and .BR dot (1) dependency graphs. Moreover, users can add their own @@ -112,7 +127,9 @@ to display it. Dynamically load the given file (which extension usually is .cmo or .cma), which defines a custom documentation generator. If the given file is a simple one and does not exist in -the current directory, then ocamldoc looks for it in the custom +the current directory, then +.B ocamldoc +looks for it in the custom generators default directory, and in the directories specified with the .B \-i option. @@ -236,7 +253,9 @@ as the title for the generated documentation. .BI \-intro \ file Use content of .I file -as ocamldoc text to use as introduction (HTML, LaTeX and TeXinfo only). +as +.B ocamldoc +text to use as introduction (HTML, LaTeX and TeXinfo only). For HTML, the file is used to create the whole "index.html" file. .TP .B \-v @@ -249,16 +268,20 @@ Print version string and exit. Print short version number and exit. .TP .B \-warn\-error -Treat Ocamldoc warnings as errors. +Treat +.B ocamldoc +warnings as errors. .TP .B \-hide\-warnings -Do not print OCamldoc warnings. +Do not print +.B ocamldoc +warnings. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SS "Type-checking options" .BR ocamldoc (1) -calls the Objective Caml type-checker to obtain type information. The +calls the OCaml type-checker to obtain type information. The following options impact the type-checking phase. They have the same meaning as for the .BR ocamlc (1)\ and \ ocamlopt (1) @@ -430,5 +453,5 @@ Set the section number used for generated man filenames. Default is 3. .BR ocamlc (1), .BR ocamlopt (1). .br -.IR "The Objective Caml user's manual", +.IR "The OCaml user's manual", chapter "The documentation generator". diff --git a/man/ocamllex.m b/man/ocamllex.m index e117dc47..314af516 100644 --- a/man/ocamllex.m +++ b/man/ocamllex.m @@ -1,8 +1,21 @@ -\" $Id$ +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLLEX 1 .SH NAME -ocamllex \- The Objective Caml lexer generator +ocamllex \- The OCaml lexer generator .SH SYNOPSIS .B ocamllex @@ -18,7 +31,7 @@ ocamllex \- The Objective Caml lexer generator The .BR ocamllex (1) -command generates Objective Caml lexers from a set of regular +command generates OCaml lexers from a set of regular expressions with associated semantic actions, in the style of .BR lex (1). @@ -26,7 +39,7 @@ Running .BR ocamllex (1) on the input file .IR lexer \&.mll -produces Caml code for a lexical analyzer in file +produces OCaml code for a lexical analyzer in file .IR lexer \&.ml. This file defines one lexing function per entry point in the lexer @@ -53,7 +66,7 @@ command recognizes the following options: .TP .B \-ml Output code that does not use OCaml's built-in automata -interpreter. Instead, the automaton is encoded by Caml functions. +interpreter. Instead, the automaton is encoded by OCaml functions. This option is mainly useful for debugging .BR ocamllex (1), using it for production lexers is not recommended. @@ -83,5 +96,5 @@ Display a short usage summary and exit. .SH SEE ALSO .BR ocamlyacc (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Lexer and parser generators". diff --git a/man/ocamlmktop.m b/man/ocamlmktop.m index d84381e1..f9c014c5 100644 --- a/man/ocamlmktop.m +++ b/man/ocamlmktop.m @@ -1,4 +1,17 @@ -\" $Id$ +.\"*********************************************************************** +.\"* * +.\"* OCaml * +.\"* * +.\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +.\"* * +.\"* Copyright 1999 Institut National de Recherche en Informatique et * +.\"* en Automatique. All rights reserved. This file is distributed * +.\"* under the terms of the Q Public License version 1.0. * +.\"* * +.\"*********************************************************************** +.\" +.\" $Id$ +.\" .TH OCAMLMKTOP 1 .SH NAME @@ -29,7 +42,7 @@ ocamlmktop \- Building custom toplevel systems The .BR ocamlmktop (1) -command builds Objective Caml toplevels that +command builds OCaml toplevels that contain user code preloaded at start-up. The .BR ocamlmktop (1) @@ -37,8 +50,8 @@ command takes as argument a set of .IR x .cmo and .IR x .cma -files, and links them with the object files that implement the Objective -Caml toplevel. If the +files, and links them with the object files that implement the +OCaml toplevel. If the .B \-custom flag is given, C object files and libraries (.o and .a files) can also be given on the command line and are linked in the resulting toplevel. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index c021fab6..0dfb196b 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -1,10 +1,22 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLOPT 1 .SH NAME -ocamlopt \- The Objective Caml native-code compiler +ocamlopt \- The OCaml native-code compiler .SH SYNOPSIS @@ -19,10 +31,10 @@ ocamlopt \- The Objective Caml native-code compiler .SH DESCRIPTION -The Objective Caml high-performance +The OCaml high-performance native-code compiler .BR ocamlopt (1) -compiles Caml source files to native code object files and link these +compiles OCaml source files to native code object files and link these object files to produce standalone executables. The @@ -65,7 +77,7 @@ should always be referred to under the name .IR x .cmx (when given a .o file, .BR ocamlopt (1) -assumes that it contains code compiled from C, not from Caml). +assumes that it contains code compiled from C, not from OCaml). The implementation is checked against the interface file .IR x .mli @@ -74,7 +86,7 @@ The implementation is checked against the interface file Arguments ending in .cmx are taken to be compiled object code. These files are linked together, along with the object files obtained -by compiling .ml arguments (if any), and the Caml Light standard +by compiling .ml arguments (if any), and the OCaml standard library, to produce a native-code executable program. The order in which .cmx and .ml arguments are presented on the command line is relevant: compilation units are initialized in that order at @@ -120,7 +132,7 @@ Thus, it behaves exactly like .BR ocamlopt , but compiles faster. .B ocamlopt.opt -is not available in all installations of Objective Caml. +is not available in all installations of OCaml. .SH OPTIONS @@ -158,6 +170,11 @@ 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. +.TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no @@ -318,9 +335,9 @@ option is given, specify the name of plugin file produced. .TP .B \-output\-obj Cause the linker to produce a C object file instead of an executable -file. This is useful to wrap Caml code as a C library, -callable from any C program. The name of the output object file is -camlprog.o by default; it can be set with the +file. This is useful to wrap OCaml code as a C library, +callable from any C program. The name of the output object file +must be set with the .B \-o option. This option can also be used to produce a compiled shared/dynamic @@ -378,7 +395,7 @@ Multiple levels of packing can be achieved by combining with .BR \-for\-pack . See -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Native-code compilation" for more details. .TP .BI \-pp \ command @@ -403,6 +420,16 @@ only recursive types where the recursion goes through an object type are supported. Note that once you have created an interface using this flag, you must use it again for all dependencies. .TP +.BI \-runtime\-variant \ suffix +Add +.I suffix +to the name of the runtime library that will be used by the program. +If OCaml was configured with option +.BR \-with\-debug\-runtime , +then the +.B d +suffix is supported and gives a debug version of the runtime. +.TP .B \-S Keep the assembly code produced during the compilation. The assembly code for the source file @@ -417,21 +444,24 @@ the module. The name of the plugin must be set with the .B \-o -option. A plugin can include a number of Caml +option. A plugin can include a number of OCaml modules and libraries, and extra native objects (.o, .a files). Building native plugins is only supported for some operating system. Under some systems (currently, -only Linux AMD 64), all the Caml code linked in a plugin must have +only Linux AMD 64), all the OCaml code linked in a plugin must have been compiled without the .B \-nodynlink 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 \-strict\-sequence +The left-hand part of a sequence must have type unit. +.TP .B \-thread Compile or link multithreaded programs, in combination with the system threads library described in -.IR "The Objective Caml user's manual" . +.IR "The OCaml user's manual" . .TP .B \-unsafe Turn bound checking off for array and string accesses (the @@ -486,14 +516,14 @@ sign (or a lowercase letter) turns them back into warnings, and a .B @ sign both enables and marks the corresponding warnings. -Note: it is not recommended to use warning sets (i.e. letters) as -arguments to +Note: it is not recommended to use the .B \-warn\-error -in production code, because this can break your build when future versions -of OCaml add some new warnings. +option in production code, because it will almost certainly prevent +compiling your program with later versions of OCaml when they add new +warnings. The default setting is -.B \-warn\-error\ +a +.B \-warn\-error\ -a (none of the warnings is treated as an error). .TP .B \-where @@ -559,5 +589,5 @@ SPARC processors. .SH SEE ALSO .BR ocamlc (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Native-code compilation". diff --git a/man/ocamlprof.m b/man/ocamlprof.m index f92ab8e4..3f20398f 100644 --- a/man/ocamlprof.m +++ b/man/ocamlprof.m @@ -1,8 +1,21 @@ -\" $Id$ +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLPROF 1 .SH NAME -ocamlprof \- The Objective Caml profiler +ocamlprof \- The OCaml profiler .SH SYNOPSIS .B ocamlprof @@ -15,7 +28,7 @@ ocamlprof \- The Objective Caml profiler The .B ocamlprof command prints execution counts gathered during the execution of a -Objective Caml program instrumented with +OCaml program instrumented with .BR ocamlcp (1). It produces a source listing of the program modules given as arguments @@ -69,5 +82,5 @@ Display a short usage summary and exit. .SH SEE ALSO .BR ocamlcp (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Profiling". diff --git a/man/ocamlrun.m b/man/ocamlrun.m index d7e7f037..7aef64ee 100644 --- a/man/ocamlrun.m +++ b/man/ocamlrun.m @@ -1,9 +1,21 @@ -\" $Id$ - +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLRUN 1 .SH NAME -ocamlrun \- The Objective Caml bytecode interpreter +ocamlrun \- The OCaml bytecode interpreter .SH SYNOPSIS .B ocamlrun @@ -23,7 +35,7 @@ command. The first non-option argument is taken to be the name of the file containing the executable bytecode. (That file is searched in the executable path as well as in the current directory.) The remaining -arguments are passed to the Objective Caml program, in the string array +arguments are passed to the OCaml program, in the string array .BR Sys.argv . Element 0 of this array is the name of the bytecode executable file; elements 1 to @@ -60,6 +72,7 @@ flag in the OCAMLRUNPARAM environment variable (see below). Search the directory .I dir for dynamically-loaded libraries, in addition to the standard search path. +.TP .B \-p Print the names of the primitives known to this version of .BR ocamlrun (1) @@ -85,14 +98,14 @@ The following environment variable are also consulted: Additional directories to search for dynamically-loaded libraries. .TP .B OCAMLLIB -The directory containing the Objective Caml standard +The directory containing the OCaml standard library. (If .B OCAMLLIB is not set, .B CAMLLIB will be used instead.) Used to locate the ld.conf configuration file for dynamic loading. If not set, -default to the library directory specified when compiling Objective Caml. +default to the library directory specified when compiling OCaml. .TP .B OCAMLRUNPARAM Set the runtime system options and garbage collection parameters. @@ -105,7 +118,7 @@ and an optional multiplier. There are nine options, six of which correspond to the fields of the .B control record documented in -.IR "The Objective Caml user's manual", +.IR "The OCaml user's manual", chapter "Standard Library", section "Gc". .TP .B b @@ -199,5 +212,5 @@ List of directories searched to find the bytecode executable file. .SH SEE ALSO .BR ocamlc (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Runtime system". diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m index 232b1727..ce53cc4a 100644 --- a/man/ocamlyacc.m +++ b/man/ocamlyacc.m @@ -1,8 +1,21 @@ -\" $Id$ +.\"*********************************************************************** +.\"* * +.\"* 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$ +.\" .TH OCAMLYACC 1 .SH NAME -ocamlyacc \- The Objective Caml parser generator +ocamlyacc \- The OCaml parser generator .SH SYNOPSIS .B ocamlyacc @@ -30,7 +43,7 @@ Assuming the input file is .IR grammar \&.mly, running .B ocamlyacc -produces Caml code for a parser in the file +produces OCaml code for a parser in the file .IR grammar \&.ml, and its interface in file .IR grammar \&.mli. @@ -91,5 +104,5 @@ command line. .SH SEE ALSO .BR ocamllex (1). .br -.IR "The Objective Caml user's manual" , +.IR "The OCaml user's manual" , chapter "Lexer and parser generators". diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 663847b4..a95db6f3 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) (* *) @@ -289,7 +289,7 @@ Pathname.define_context "ocamlbuild" ["ocamlbuild"; "stdlib"; "."];; Pathname.define_context "lex" ["lex"; "stdlib"];; List.iter (fun x -> let x = "otherlibs"/x in Pathname.define_context x [x; "stdlib"]) - ["bigarray"; "dbm"; "graph"; "num"; "str"; "systhreads"; "unix"; "win32graph"; "win32unix"];; + ["bigarray"; "graph"; "num"; "str"; "systhreads"; "unix"; "win32graph"; "win32unix"];; (* The bootstrap standard library *) copy_rule "The bootstrap standard library" "stdlib/%" "boot/%";; @@ -407,8 +407,6 @@ flag ["c"; "compile"; "otherlibs_bigarray"] (S[A"-I"; P"../otherlibs/bigarray"]) flag [(* "ocaml" or "c"; *) "ocamlmklib"; "otherlibs_graph"] (S[Sh C.x11_link]);; flag ["c"; "compile"; "otherlibs_graph"] (S[Sh C.x11_includes; A"-I../otherlibs/graph"]);; flag ["c"; "compile"; "otherlibs_win32graph"] (A"-I../otherlibs/win32graph");; -flag ["c"; "compile"; "otherlibs_dbm"] (Sh C.dbm_includes);; -flag [(* "ocaml" oc "c"; *) "ocamlmklib"; "otherlibs_dbm"] (S[A"-oc"; A"otherlibs/dbm/mldbm"; Sh C.dbm_link]);; flag ["ocaml"; "ocamlmklib"; "otherlibs_threads"] (S[A"-oc"; A"otherlibs/threads/vmthreads"]);; flag ["c"; "compile"; "otherlibs_num"] begin S[A("-DBNG_ARCH_"^C.bng_arch); @@ -676,7 +674,6 @@ let special_modules = let camlp4_import_list = ["utils/misc.ml"; "utils/terminfo.ml"; - "parsing/linenum.ml"; "utils/warnings.ml"; "parsing/location.ml"; "parsing/longident.ml"; @@ -1049,7 +1046,7 @@ rule "labltk" ~prod:"otherlibs/labltk/lib/labltk" begin fun _ _ -> Echo(["#!/bin/sh\n"; - Printf.sprintf "exec %s -I %s $*\n" (labltk_installdir/"labltktop") labltk_installdir], + Printf.sprintf "exec %s -I %s \"$@\"\n" (labltk_installdir/"labltktop") labltk_installdir], "otherlibs/labltk/lib/labltk") end;; diff --git a/myocamlbuild_config.mli b/myocamlbuild_config.mli index 28b22617..5eec9803 100644 --- a/myocamlbuild_config.mli +++ b/myocamlbuild_config.mli @@ -1,9 +1,22 @@ +(*************************************************************************) +(* *) +(* 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. *) +(* *) +(*************************************************************************) + val prefix : string val bindir : string val libdir : string val manext : string val ranlib : string val ranlibcmd : string +val arcmd : string val sharpbangscripts : bool val bng_arch : string val bng_asm_level : string @@ -11,8 +24,6 @@ val pthread_link : string val x11_includes : string val x11_link : string val tk_link : string -val dbm_includes : string -val dbm_link : string val bytecc : string val bytecccompopts : string val bytecclinkopts : string diff --git a/ocamlbuild/ChangeLog b/ocamlbuild/ChangeLog index a844e38b..0899500e 100644 --- a/ocamlbuild/ChangeLog +++ b/ocamlbuild/ChangeLog @@ -2302,7 +2302,7 @@ 2006-12-08 Nicolas Pouillard - Ocaml distrib stuffs. + OCaml distrib stuffs. * command.ml, * command.mli: Add a normalization callback. diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index 0f190336..e4ee877e 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -1,6 +1,6 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # # # diff --git a/ocamlbuild/_tags b/ocamlbuild/_tags index 617d6a72..cf63d892 100644 --- a/ocamlbuild/_tags +++ b/ocamlbuild/_tags @@ -1,10 +1,22 @@ +######################################################################### +# # +# 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. # +# # +######################################################################### + # OCamlbuild tags file true: debug <*.ml> or <*.mli>: warn_L, warn_R, warn_Z, annot "discard_printf.ml": rectypes "ocamlbuildlib.cma" or "ocamlbuildlightlib.cma": linkall <*.byte> or <*.native> or <*.top>: use_unix -"ocamlbuildlight.byte": -use_unix +"ocamlbuildlight.byte": -use_unix, nopervasives <*.cmx>: for-pack(Ocamlbuild_pack) <{ocamlbuild_{pack,unix_plugin,plugin,executor},ppcache}{,.p}.cmx>: -for-pack(Ocamlbuild_pack) "doc": not_hygienic diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index 131cd858..1ce80c97 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -91,9 +91,15 @@ let atomize_paths l = S(List.map (fun x -> P x) l) let env_path = lazy begin let path_var = Sys.getenv "PATH" in + let parse_path = + if Sys.os_type = "Win32" then + Lexers.parse_environment_path_w + else + Lexers.parse_environment_path + in let paths = try - Lexers.parse_environment_path (Lexing.from_string path_var) + parse_path (Lexing.from_string path_var) with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg)) in let norm_current_dir_name path = @@ -119,21 +125,33 @@ let virtual_solver virtual_command = failwith (Printf.sprintf "the solver for the virtual command %S \ has failed finding a valid command" virtual_command) +(* On Windows, we need to also check for the ".exe" version of the file. *) +let file_or_exe_exists file = + sys_file_exists file || Sys.os_type = "Win32" && sys_file_exists (file ^ ".exe") -(* FIXME windows *) let search_in_path cmd = + (* Try to find [cmd] in path [path]. *) + let try_path path = + (* Don't know why we're trying to be subtle here... *) + if path = Filename.current_dir_name then file_or_exe_exists cmd + else file_or_exe_exists (filename_concat path cmd) + in if Filename.is_implicit cmd then - let path = List.find begin fun path -> - if path = Filename.current_dir_name then sys_file_exists cmd - else sys_file_exists (filename_concat path cmd) - end !*env_path in + let path = List.find try_path !*env_path in + (* We're not trying to append ".exe" here because all windows shells are + * capable of understanding the command without the ".exe" suffix. *) filename_concat path cmd - else cmd + else + cmd (*** string_of_command_spec{,_with_calls *) let rec string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec = let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in let b = Buffer.create 256 in + (* The best way to prevent bash from switching to its windows-style + * quote-handling is to prepend an empty string before the command name. *) + if Sys.os_type = "Win32" then + Buffer.add_string b "''"; let first = ref true in let put_space () = if !first then diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli index 0cdc602c..f54b8e8a 100644 --- a/ocamlbuild/command.mli +++ b/ocamlbuild/command.mli @@ -44,3 +44,5 @@ val deps_of_tags : Tags.t -> pathname list val dep : Tags.elt list -> pathname list -> unit val pdep : Tags.elt list -> Tags.elt -> (string -> pathname list) -> unit + +val file_or_exe_exists: string -> bool diff --git a/ocamlbuild/digest_cache.ml b/ocamlbuild/digest_cache.ml index 95ddfed1..5f624afc 100644 --- a/ocamlbuild/digest_cache.ml +++ b/ocamlbuild/digest_cache.ml @@ -20,7 +20,7 @@ let get = Hashtbl.find digests let put = Hashtbl.replace digests -let _digests = lazy (Pathname.pwd / !Options.build_dir / (Pathname.mk "_digests")) +let _digests = lazy (!Options.build_dir / (Pathname.mk "_digests")) let finalize () = with_output_file !*_digests begin fun oc -> diff --git a/ocamlbuild/exit_codes.ml b/ocamlbuild/exit_codes.ml index 19cb4f02..71c9f06f 100644 --- a/ocamlbuild/exit_codes.ml +++ b/ocamlbuild/exit_codes.ml @@ -1,3 +1,14 @@ +(***********************************************************************) +(* 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 rc_ok = 0 let rc_usage = 1 let rc_failure = 2 diff --git a/ocamlbuild/exit_codes.mli b/ocamlbuild/exit_codes.mli index acbc0ede..a83a300b 100644 --- a/ocamlbuild/exit_codes.mli +++ b/ocamlbuild/exit_codes.mli @@ -1,3 +1,14 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + val rc_ok : int val rc_usage : int val rc_failure : int diff --git a/ocamlbuild/fda.ml b/ocamlbuild/fda.ml index 4d4bbac0..d359f781 100644 --- a/ocamlbuild/fda.ml +++ b/ocamlbuild/fda.ml @@ -22,10 +22,10 @@ exception Exit_hygiene_failed let laws = [ - { law_name = "Leftover Ocaml compilation files"; + { law_name = "Leftover OCaml compilation files"; law_rules = [Not ".cmo"; Not ".cmi"; Not ".cmx"; Not ".cma"; Not ".cmxa"]; law_penalty = Fail }; - { law_name = "Leftover Ocaml type annotation files"; + { law_name = "Leftover OCaml type annotation files"; law_rules = [Not ".annot"]; law_penalty = Warn }; { law_name = "Leftover object files"; diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml index e904afb4..97a9ea92 100644 --- a/ocamlbuild/hygiene.ml +++ b/ocamlbuild/hygiene.ml @@ -150,7 +150,9 @@ let check ?sanitize laws entry = @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\ @ or@ using@ the@ -no-hygiene@ option).@]" m (if m = 1 then "" else "s") fn; - let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o755 fn in + let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o755 fn in + (* See PR #5338: under mingw, one produces a shell script, which must follow + Unix eol convention; hence Open_binary. *) let fp = Printf.fprintf in fp oc "#!/bin/sh\n\ # File generated by ocamlbuild\n\ diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index 2f37edca..bc5de4cf 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -32,6 +32,8 @@ val trim_blanks : Lexing.lexbuf -> string Example: ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *) 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 path_scheme : bool -> Lexing.lexbuf -> diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index 7b191b0d..2206f862 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -81,6 +81,15 @@ and comma_or_blank_sep_strings_aux = parse | space* eof { [] } | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") } +and parse_environment_path_w = parse + | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } + | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w lexbuf } + | eof { [] } +and parse_environment_path_aux_w = parse + | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } + | eof { [] } + | _ { raise (Error "Impossible: expecting colon-separated strings") } + and parse_environment_path = parse | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux lexbuf } diff --git a/ocamlbuild/man/ocamlbuild.1 b/ocamlbuild/man/ocamlbuild.1 index 58a33740..918c5981 100644 --- a/ocamlbuild/man/ocamlbuild.1 +++ b/ocamlbuild/man/ocamlbuild.1 @@ -1,7 +1,18 @@ +.\"***********************************************************************) +.\"* 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. *) +.\"* *) +.\"***********************************************************************) +.\" .TH OCAMLBUILD 1 .SH NAME -ocamlbuild \- The Objective Caml project compilation tool +ocamlbuild \- The OCaml project compilation tool .SH SYNOPSIS @@ -57,7 +68,7 @@ produce. Target names are of the form .BR base.extension where .BR base -is usually the name of the underlying Ocaml module and +is usually the name of the underlying OCaml module and .BR extension denotes the kind of object to produce from that file -- a byte code executable, a native executable, documentation... @@ -250,4 +261,4 @@ manual, .BR ocaml (1), .BR make (1). .br -.I The Objective Caml user's manual, chapter "Batch compilation". +.I The OCaml user's manual, chapter "Batch compilation". diff --git a/ocamlbuild/manual/.cvsignore b/ocamlbuild/manual/.cvsignore deleted file mode 100644 index a7bf093d..00000000 --- a/ocamlbuild/manual/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -*.aux -*.haux -*.html -*.htoc -*.log -*.pdf diff --git a/ocamlbuild/manual/.ignore b/ocamlbuild/manual/.ignore new file mode 100644 index 00000000..a7bf093d --- /dev/null +++ b/ocamlbuild/manual/.ignore @@ -0,0 +1,6 @@ +*.aux +*.haux +*.html +*.htoc +*.log +*.pdf diff --git a/ocamlbuild/manual/Makefile b/ocamlbuild/manual/Makefile index 055d42e7..595f730e 100644 --- a/ocamlbuild/manual/Makefile +++ b/ocamlbuild/manual/Makefile @@ -1,3 +1,14 @@ +####################################################################### +# 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. # +# # +####################################################################### + # Makefile all: manual.pdf manual.html diff --git a/ocamlbuild/manual/manual.tex b/ocamlbuild/manual/manual.tex index 62d90045..bccdd9a6 100644 --- a/ocamlbuild/manual/manual.tex +++ b/ocamlbuild/manual/manual.tex @@ -1,4 +1,15 @@ % -*- LaTeX -*- +%(***********************************************************************) +%(* 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. *) +%(* *) +%(***********************************************************************) + %(*** preamble \documentclass[9pt]{article} \usepackage[utf8]{inputenc} @@ -609,7 +620,7 @@ library. Just write a file with the \texttt{mltop} extension (like \subsection{Preprocessor options and tags} You can specify preprocessor options with \texttt{-pp} followed by the preprocessor string, for instance \texttt{ocamlbuild -pp "camlp4o.opt -unsafe"} -would run your sources thru CamlP4 with the \texttt{-unsafe} option. +would run your sources through CamlP4 with the \texttt{-unsafe} option. Another way is to use the tags file. \begin{center} \begin{tabular}{|l|l|l|} diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index 78286b53..3ba85502 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -249,18 +249,17 @@ let sys_command = | "Win32" -> fun cmd -> if cmd = "" then 0 else let cmd = "bash -c "^Filename.quote cmd in - (* FIXME fix Filename.quote for windows *) - let cmd = String.subst "\"&\"\"&\"" "&&" cmd in Sys.command cmd | _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd (* FIXME warning fix and use Filename.concat *) let filename_concat x y = if x = Filename.current_dir_name || x = "" then y else - if x.[String.length x - 1] = '/' then + if Sys.os_type = "Win32" && (x.[String.length x - 1] = '\\') || x.[String.length x - 1] = '/' then if y = "" then x else x ^ y - else x ^ "/" ^ y + else + x ^ "/" ^ y (* let reslash = match Sys.os_type with diff --git a/ocamlbuild/ocaml_dependencies.mli b/ocamlbuild/ocaml_dependencies.mli index 68bc427c..5c1ebfe6 100644 --- a/ocamlbuild/ocaml_dependencies.mli +++ b/ocamlbuild/ocaml_dependencies.mli @@ -11,7 +11,7 @@ (* Original author: Nicolas Pouillard *) -(** Ocaml dependencies *) +(** OCaml dependencies *) exception Circular_dependencies of string list * string diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 1b830add..79c14937 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -434,7 +434,7 @@ let () = (* tags package(X), predicate(X) and syntax(X) *) List.iter begin fun tags -> pflag tags "package" (fun pkg -> S [A "-package"; A pkg]); - pflag tags "predicate" (fun pkg -> S [A "-predicate"; A pkg]); + pflag tags "predicate" (fun pkg -> S [A "-predicates"; A pkg]); pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg]) end all_tags end else begin @@ -527,7 +527,9 @@ flag ["ocaml"; "compile"; "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"; "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") end;; diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml index 1381ca46..f68aff42 100644 --- a/ocamlbuild/ocaml_tools.ml +++ b/ocamlbuild/ocaml_tools.ml @@ -93,6 +93,7 @@ let infer_interface ml mli env build = let tags = tags_of_pathname ml++"ocaml" in Ocaml_compiler.prepare_compile build ml; Cmd(S[!Options.ocamlc; ocaml_ppflags tags; ocaml_include_flags ml; A"-i"; + (if Tags.mem "thread" tags then A"-thread" else N); T(tags++"infer_interface"); P ml; Sh">"; Px mli]) let menhir mly env build = diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 3dafe25a..7726825c 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -29,8 +29,7 @@ let flag_and_dep tags cmd_spec = dep tags ps let stdlib_dir = lazy begin - (* FIXME *) - let ocamlc_where = sprintf "%s/ocamlc.where" (Pathname.pwd / !Options.build_dir) in + let ocamlc_where = !Options.build_dir / (Pathname.mk "ocamlc.where") in let () = Command.execute ~quiet:true (Cmd(S[!Options.ocamlc; A"-where"; Sh">"; P ocamlc_where])) in String.chomp (read_file ocamlc_where) end diff --git a/ocamlbuild/ocamlbuild-presentation.rslide b/ocamlbuild/ocamlbuild-presentation.rslide index 30ba657b..bb32c477 100644 --- a/ocamlbuild/ocamlbuild-presentation.rslide +++ b/ocamlbuild/ocamlbuild-presentation.rslide @@ -1,3 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# 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. # +# # +######################################################################### + # Works with rslide revision 8 # http://gallium.inria.fr/~pouillar/rslide/rslide documentclass :beamer, :t, :compress, :red @@ -109,7 +121,7 @@ slide "How difficult is it to build regular projects by hand?" do end slide "How does ocamlbuild manage all that?" do - > It has a lot of hand-crafted Ocaml-specific compilation logic! + > It has a lot of hand-crafted OCaml-specific compilation logic! box "A dynamic exploration approach", '<2>' do * Start from the given targets * Attempt to discover dependencies using _ocamldep_ diff --git a/ocamlbuild/ocamlbuild_plugin.mli b/ocamlbuild/ocamlbuild_plugin.mli index 8e642f31..0844b4d7 100644 --- a/ocamlbuild/ocamlbuild_plugin.mli +++ b/ocamlbuild/ocamlbuild_plugin.mli @@ -1,3 +1,14 @@ +(***********************************************************************) +(* 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. *) +(* *) +(***********************************************************************) + include Ocamlbuild_pack.Signatures.PLUGIN with module Pathname = Ocamlbuild_pack.Pathname and module Outcome = Ocamlbuild_pack.My_std.Outcome diff --git a/ocamlbuild/ocamlbuild_where.ml b/ocamlbuild/ocamlbuild_where.ml index 14fcde5d..d65b41ed 100644 --- a/ocamlbuild/ocamlbuild_where.ml +++ b/ocamlbuild/ocamlbuild_where.ml @@ -1,3 +1,14 @@ +(***********************************************************************) +(* 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 bindir = ref Ocamlbuild_Myocamlbuild_config.bindir;; let libdir = ref begin Filename.concat diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index e547d44e..d17e0dc1 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -22,7 +22,7 @@ open Format open Command let entry = ref None -let build_dir = ref "_build" +let build_dir = ref (Filename.concat (Sys.getcwd ()) "_build") let include_dirs = ref [] let exclude_dirs = ref [] let nothing_should_be_rebuilt = ref false @@ -50,8 +50,8 @@ let mk_virtual_solvers = if sys_file_exists !dir then let long = filename_concat !dir cmd in let long_opt = long ^ ".opt" in - if sys_file_exists long_opt then A long_opt - else if sys_file_exists long then A long + 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 @@ -126,7 +126,12 @@ let add_to' rxs x = else () let set_cmd rcmd = String (fun s -> rcmd := Sh s) -let set_build_dir s = make_links := false; build_dir := s +let set_build_dir s = + make_links := false; + if Filename.is_relative s then + build_dir := Filename.concat (Sys.getcwd ()) s + else + build_dir := s let spec = ref ( Arg.align [ diff --git a/ocamlbuild/shell.ml b/ocamlbuild/shell.ml index c76d1545..3fbeb81a 100644 --- a/ocamlbuild/shell.ml +++ b/ocamlbuild/shell.ml @@ -23,7 +23,12 @@ let is_simple_filename s = | _ -> false in loop 0 let quote_filename_if_needed s = - if is_simple_filename s then s else Filename.quote s + if is_simple_filename s then s + (* We should probably be using [Filename.unix_quote] except that function + * isn't exported. Users on Windows will have to live with not being able to + * install OCaml into c:\o'caml. Too bad. *) + else if Sys.os_type = "Win32" then Printf.sprintf "'%s'" s + else Filename.quote s let chdir dir = reset_filesys_cache (); Sys.chdir dir diff --git a/ocamlbuild/shell.mli b/ocamlbuild/shell.mli index d393c7b3..2d867b03 100644 --- a/ocamlbuild/shell.mli +++ b/ocamlbuild/shell.mli @@ -9,10 +9,14 @@ (* *) (***********************************************************************) - (* Original author: Nicolas Pouillard *) + val is_simple_filename : string -> bool + val quote_filename_if_needed : string -> string +(** This will quote using Unix conventions, even on Windows, because commands are + * always run through bash -c on Windows. *) + val chdir : string -> unit val rm : string -> unit val rm_f : string -> unit diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh index 20b7b765..7386cbd3 100755 --- a/ocamlbuild/start.sh +++ b/ocamlbuild/start.sh @@ -2,7 +2,7 @@ ######################################################################### # # -# Objective Caml # +# OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # diff --git a/ocamldoc/.cvsignore b/ocamldoc/.cvsignore deleted file mode 100644 index 0372a098..00000000 --- a/ocamldoc/.cvsignore +++ /dev/null @@ -1,17 +0,0 @@ -ocamldoc -ocamldoc.opt -odoc_crc.ml -odoc_lexer.ml -odoc_ocamlhtml.ml -odoc_parser.ml -odoc_parser.mli -odoc_see_lexer.ml -odoc_text_lexer.ml -odoc_text_parser.ml -odoc_text_parser.mli -stdlib_man -*.output -test_stdlib -test_latex -test -*.a diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 355a0a2f..09162d0f 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,12 +1,12 @@ -odoc.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \ - odoc_man.cmo odoc_latex.cmo odoc_info.cmi odoc_html.cmo odoc_global.cmi \ - odoc_dot.cmo odoc_config.cmi odoc_args.cmi odoc_analyse.cmi \ - ../utils/misc.cmi ../utils/config.cmi ../utils/clflags.cmi -odoc.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \ - odoc_man.cmx odoc_latex.cmx odoc_info.cmx odoc_html.cmx odoc_global.cmx \ - odoc_dot.cmx odoc_config.cmx odoc_args.cmx odoc_analyse.cmx \ - ../utils/misc.cmx ../utils/config.cmx ../utils/clflags.cmx -odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ +odoc.cmo : ../typing/typedtree.cmi odoc_messages.cmo odoc_info.cmi \ + odoc_global.cmi odoc_gen.cmi odoc_config.cmi odoc_args.cmi \ + odoc_analyse.cmi ../utils/misc.cmi ../utils/config.cmi \ + ../utils/clflags.cmi +odoc.cmx : ../typing/typedtree.cmx odoc_messages.cmx odoc_info.cmx \ + odoc_global.cmx odoc_gen.cmx odoc_config.cmx odoc_args.cmx \ + odoc_analyse.cmx ../utils/misc.cmx ../utils/config.cmx \ + ../utils/clflags.cmx +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 \ @@ -14,11 +14,11 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.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 \ - odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \ - ../parsing/lexer.cmi ../typing/includemod.cmi ../typing/env.cmi \ - ../typing/ctype.cmi ../utils/config.cmi ../utils/clflags.cmi \ - ../utils/ccomp.cmi odoc_analyse.cmi -odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ + ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ + ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \ + ../utils/config.cmi ../utils/clflags.cmi ../utils/ccomp.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 \ @@ -26,220 +26,231 @@ odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.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 \ - odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \ - ../parsing/lexer.cmx ../typing/includemod.cmx ../typing/env.cmx \ - ../typing/ctype.cmx ../utils/config.cmx ../utils/clflags.cmx \ - ../utils/ccomp.cmx odoc_analyse.cmi -odoc_args.cmo: odoc_types.cmi odoc_module.cmo odoc_messages.cmo \ - odoc_global.cmi odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi \ - ../utils/clflags.cmi odoc_args.cmi -odoc_args.cmx: odoc_types.cmx odoc_module.cmx odoc_messages.cmx \ - odoc_global.cmx odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx \ - ../utils/clflags.cmx odoc_args.cmi -odoc_ast.cmo: ../typing/types.cmi ../typing/typedtree.cmi \ + ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ + ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \ + ../utils/config.cmx ../utils/clflags.cmx ../utils/ccomp.cmx \ + 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 +odoc_args.cmx : odoc_types.cmx odoc_texi.cmx odoc_messages.cmx odoc_man.cmx \ + odoc_latex.cmx odoc_html.cmx odoc_global.cmx odoc_gen.cmx odoc_dot.cmx \ + odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx odoc_args.cmi +odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \ odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ - odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \ - ../typing/ident.cmi ../parsing/asttypes.cmi odoc_ast.cmi -odoc_ast.cmx: ../typing/types.cmx ../typing/typedtree.cmx \ + ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ + ../parsing/asttypes.cmi odoc_ast.cmi +odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ - odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \ - ../typing/ident.cmx ../parsing/asttypes.cmi odoc_ast.cmi -odoc_class.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ + ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ + ../parsing/asttypes.cmi odoc_ast.cmi +odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi -odoc_class.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ +odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx -odoc_comments.cmo: odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ +odoc_comments.cmo : odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi \ odoc_lexer.cmo odoc_global.cmi odoc_cross.cmi odoc_comments_global.cmi \ odoc_comments.cmi -odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ +odoc_comments.cmx : odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \ odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \ odoc_comments.cmi -odoc_comments_global.cmo: odoc_comments_global.cmi -odoc_comments_global.cmx: odoc_comments_global.cmi -odoc_config.cmo: ../utils/config.cmi odoc_config.cmi -odoc_config.cmx: ../utils/config.cmx odoc_config.cmi -odoc_control.cmo: -odoc_control.cmx: -odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ +odoc_comments_global.cmo : odoc_comments_global.cmi +odoc_comments_global.cmx : odoc_comments_global.cmi +odoc_config.cmo : ../utils/config.cmi odoc_config.cmi +odoc_config.cmx : ../utils/config.cmx odoc_config.cmi +odoc_control.cmo : +odoc_control.cmx : +odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ - odoc_cross.cmi -odoc_cross.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ + odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ + odoc_class.cmo odoc_cross.cmi +odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ - odoc_cross.cmi -odoc_dag2html.cmo: odoc_info.cmi odoc_dag2html.cmi -odoc_dag2html.cmx: odoc_info.cmx odoc_dag2html.cmi -odoc_dep.cmo: ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \ + odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ + odoc_class.cmx odoc_cross.cmi +odoc_dag2html.cmo : odoc_info.cmi odoc_dag2html.cmi +odoc_dag2html.cmx : odoc_info.cmx odoc_dag2html.cmi +odoc_dep.cmo : ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \ odoc_module.cmo ../tools/depend.cmi -odoc_dep.cmx: ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \ +odoc_dep.cmx : ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \ odoc_module.cmx ../tools/depend.cmx -odoc_dot.cmo: odoc_info.cmi -odoc_dot.cmx: odoc_info.cmx -odoc_env.cmo: ../typing/types.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ - ../typing/path.cmi odoc_name.cmi ../typing/btype.cmi odoc_env.cmi -odoc_env.cmx: ../typing/types.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ - ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx odoc_env.cmi -odoc_exception.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi -odoc_exception.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx -odoc_global.cmo: ../utils/clflags.cmi odoc_global.cmi -odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi -odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ - odoc_info.cmi odoc_dag2html.cmi odoc_args.cmi ../parsing/asttypes.cmi -odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ - odoc_info.cmx odoc_dag2html.cmx odoc_args.cmx ../parsing/asttypes.cmi -odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ +odoc_dot.cmo : odoc_messages.cmo odoc_info.cmi +odoc_dot.cmx : odoc_messages.cmx odoc_info.cmx +odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ + ../typing/predef.cmi ../typing/path.cmi odoc_name.cmi ../typing/btype.cmi \ + odoc_env.cmi +odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ + ../typing/predef.cmx ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx \ + odoc_env.cmi +odoc_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi +odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx +odoc_gen.cmo : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ + odoc_html.cmo odoc_dot.cmo odoc_gen.cmi +odoc_gen.cmx : odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \ + odoc_html.cmx odoc_dot.cmx odoc_gen.cmi +odoc_global.cmo : odoc_types.cmi odoc_messages.cmo odoc_config.cmi \ + ../utils/clflags.cmi odoc_global.cmi +odoc_global.cmx : odoc_types.cmx odoc_messages.cmx odoc_config.cmx \ + ../utils/clflags.cmx odoc_global.cmi +odoc_html.cmo : odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ + odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi +odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ + odoc_info.cmx odoc_global.cmx odoc_dag2html.cmx ../parsing/asttypes.cmi +odoc_info.cmo : ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \ odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ - odoc_dep.cmo odoc_config.cmi odoc_comments.cmi odoc_class.cmo \ - odoc_args.cmi odoc_analyse.cmi odoc_info.cmi -odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ + odoc_misc.cmi odoc_global.cmi odoc_exception.cmo odoc_dep.cmo \ + odoc_config.cmi odoc_comments.cmi odoc_class.cmo odoc_analyse.cmi \ + odoc_info.cmi +odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \ odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ - odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \ - odoc_args.cmx odoc_analyse.cmx odoc_info.cmi -odoc_inherit.cmo: -odoc_inherit.cmx: -odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ + odoc_misc.cmx odoc_global.cmx odoc_exception.cmx odoc_dep.cmx \ + odoc_config.cmx odoc_comments.cmx odoc_class.cmx odoc_analyse.cmx \ + odoc_info.cmi +odoc_inherit.cmo : +odoc_inherit.cmx : +odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ + odoc_info.cmi ../parsing/asttypes.cmi +odoc_latex.cmx : odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ + odoc_info.cmx ../parsing/asttypes.cmi +odoc_latex_style.cmo : +odoc_latex_style.cmx : +odoc_lexer.cmo : odoc_parser.cmi odoc_messages.cmo odoc_global.cmi \ + odoc_comments_global.cmi +odoc_lexer.cmx : odoc_parser.cmx odoc_messages.cmx odoc_global.cmx \ + odoc_comments_global.cmx +odoc_man.cmo : odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ odoc_info.cmi ../parsing/asttypes.cmi -odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ +odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ odoc_info.cmx ../parsing/asttypes.cmi -odoc_latex_style.cmo: -odoc_latex_style.cmx: -odoc_lexer.cmo: odoc_parser.cmi odoc_messages.cmo odoc_comments_global.cmi \ - odoc_args.cmi -odoc_lexer.cmx: odoc_parser.cmx odoc_messages.cmx odoc_comments_global.cmx \ - odoc_args.cmx -odoc_man.cmo: odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ - odoc_info.cmi odoc_args.cmi ../parsing/asttypes.cmi -odoc_man.cmx: odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ - odoc_info.cmx odoc_args.cmx ../parsing/asttypes.cmi -odoc_merge.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ +odoc_merge.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ - odoc_exception.cmo odoc_class.cmo odoc_args.cmi odoc_merge.cmi -odoc_merge.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ + odoc_global.cmi odoc_exception.cmo odoc_class.cmo odoc_merge.cmi +odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ - odoc_exception.cmx odoc_class.cmx odoc_args.cmx odoc_merge.cmi -odoc_messages.cmo: odoc_global.cmi odoc_config.cmi ../utils/config.cmi -odoc_messages.cmx: odoc_global.cmx odoc_config.cmx ../utils/config.cmx -odoc_misc.cmo: ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ + odoc_global.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi +odoc_messages.cmo : ../utils/config.cmi +odoc_messages.cmx : ../utils/config.cmx +odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ odoc_types.cmi odoc_messages.cmo ../parsing/longident.cmi \ ../typing/ctype.cmi ../typing/btype.cmi odoc_misc.cmi -odoc_misc.cmx: ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ +odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \ ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi -odoc_module.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ +odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo -odoc_module.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ +odoc_module.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx -odoc_name.cmo: ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ +odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ odoc_name.cmi -odoc_name.cmx: ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ +odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ odoc_name.cmi -odoc_ocamlhtml.cmo: -odoc_ocamlhtml.cmx: -odoc_parameter.cmo: ../typing/types.cmi odoc_types.cmi -odoc_parameter.cmx: ../typing/types.cmx odoc_types.cmx -odoc_parser.cmo: odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi -odoc_parser.cmx: odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi -odoc_print.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi -odoc_print.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi -odoc_scan.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ +odoc_ocamlhtml.cmo : +odoc_ocamlhtml.cmx : +odoc_parameter.cmo : ../typing/types.cmi odoc_types.cmi +odoc_parameter.cmx : ../typing/types.cmx odoc_types.cmx +odoc_parser.cmo : odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi +odoc_parser.cmx : odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi +odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi +odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi +odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ odoc_exception.cmo odoc_class.cmo -odoc_scan.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ +odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ odoc_exception.cmx odoc_class.cmx -odoc_search.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ +odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_exception.cmo \ odoc_class.cmo odoc_search.cmi -odoc_search.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ +odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_exception.cmx \ odoc_class.cmx odoc_search.cmi -odoc_see_lexer.cmo: odoc_parser.cmi -odoc_see_lexer.cmx: odoc_parser.cmx -odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ - ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \ - odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \ - odoc_env.cmi odoc_class.cmo odoc_args.cmi ../utils/misc.cmi \ +odoc_see_lexer.cmo : odoc_parser.cmi +odoc_see_lexer.cmx : odoc_parser.cmx +odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ + ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \ + odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ + odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ + odoc_exception.cmo odoc_env.cmi odoc_class.cmo ../utils/misc.cmi \ ../parsing/location.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ odoc_sig.cmi -odoc_sig.cmx: ../typing/types.cmx ../typing/typedtree.cmx ../typing/path.cmx \ - ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_misc.cmx \ - odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_exception.cmx \ - odoc_env.cmx odoc_class.cmx odoc_args.cmx ../utils/misc.cmx \ +odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ + ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \ + odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ + odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ + odoc_exception.cmx odoc_env.cmx odoc_class.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ odoc_sig.cmi -odoc_str.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ +odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ ../parsing/asttypes.cmi odoc_str.cmi -odoc_str.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ +odoc_str.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ ../parsing/asttypes.cmi odoc_str.cmi -odoc_test.cmo: odoc_info.cmi -odoc_test.cmx: odoc_info.cmx -odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi \ - ../parsing/asttypes.cmi -odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx \ - ../parsing/asttypes.cmi -odoc_text.cmo: odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ +odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi +odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx +odoc_texi.cmo : ../typing/types.cmi odoc_to_text.cmo odoc_messages.cmo \ + odoc_info.cmi ../parsing/asttypes.cmi +odoc_texi.cmx : ../typing/types.cmx odoc_to_text.cmx odoc_messages.cmx \ + odoc_info.cmx ../parsing/asttypes.cmi +odoc_text.cmo : odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ odoc_text.cmi -odoc_text.cmx: odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ +odoc_text.cmx : odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ odoc_text.cmi -odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_misc.cmi -odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_misc.cmx -odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi -odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi -odoc_to_text.cmo: odoc_module.cmo odoc_messages.cmo odoc_info.cmi -odoc_to_text.cmx: odoc_module.cmx odoc_messages.cmx odoc_info.cmx -odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ +odoc_text_lexer.cmo : odoc_text_parser.cmi odoc_misc.cmi +odoc_text_lexer.cmx : odoc_text_parser.cmx odoc_misc.cmx +odoc_text_parser.cmo : odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi +odoc_text_parser.cmx : odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi +odoc_to_text.cmo : odoc_module.cmo odoc_messages.cmo odoc_info.cmi +odoc_to_text.cmx : odoc_module.cmx odoc_messages.cmx odoc_info.cmx +odoc_type.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ ../parsing/asttypes.cmi -odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ +odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ ../parsing/asttypes.cmi -odoc_types.cmo: odoc_messages.cmo odoc_types.cmi -odoc_types.cmx: odoc_messages.cmx odoc_types.cmi -odoc_value.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ +odoc_types.cmo : odoc_messages.cmo odoc_types.cmi +odoc_types.cmx : odoc_messages.cmx odoc_types.cmi +odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi -odoc_value.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ +odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx -odoc_analyse.cmi: odoc_module.cmo odoc_args.cmi -odoc_args.cmi: odoc_types.cmi odoc_module.cmo -odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ - ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo -odoc_comments.cmi: odoc_types.cmi odoc_module.cmo -odoc_comments_global.cmi: -odoc_config.cmi: -odoc_cross.cmi: odoc_types.cmi odoc_module.cmo -odoc_dag2html.cmi: odoc_info.cmi -odoc_env.cmi: ../typing/types.cmi odoc_name.cmi -odoc_global.cmi: -odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ +odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi +odoc_args.cmi : odoc_gen.cmi +odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ + ../typing/path.cmi ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi \ + odoc_module.cmo +odoc_comments.cmi : odoc_types.cmi odoc_module.cmo +odoc_comments_global.cmi : +odoc_config.cmi : +odoc_cross.cmi : odoc_types.cmi odoc_module.cmo +odoc_dag2html.cmi : odoc_info.cmi +odoc_env.cmi : ../typing/types.cmi odoc_name.cmi +odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ + odoc_html.cmo odoc_dot.cmo +odoc_global.cmi : odoc_types.cmi +odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ - odoc_exception.cmo odoc_class.cmo -odoc_merge.cmi: odoc_types.cmi odoc_module.cmo -odoc_misc.cmi: ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi -odoc_name.cmi: ../typing/path.cmi ../parsing/longident.cmi \ + odoc_global.cmi odoc_exception.cmo odoc_class.cmo +odoc_merge.cmi : odoc_types.cmi odoc_module.cmo +odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi +odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ ../typing/ident.cmi -odoc_parser.cmi: odoc_types.cmi -odoc_print.cmi: ../typing/types.cmi -odoc_search.cmi: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ - odoc_exception.cmo odoc_class.cmo -odoc_sig.cmi: ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \ +odoc_parser.cmi : odoc_types.cmi +odoc_print.cmi : ../typing/types.cmi +odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ + odoc_module.cmo odoc_exception.cmo odoc_class.cmo +odoc_sig.cmi : ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo -odoc_str.cmi: ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ +odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ odoc_exception.cmo odoc_class.cmo -odoc_text.cmi: odoc_types.cmi -odoc_text_parser.cmi: odoc_types.cmi -odoc_types.cmi: +odoc_text.cmi : odoc_types.cmi +odoc_text_parser.cmi : odoc_types.cmi +odoc_types.cmi : diff --git a/ocamldoc/.ignore b/ocamldoc/.ignore new file mode 100644 index 00000000..720ee641 --- /dev/null +++ b/ocamldoc/.ignore @@ -0,0 +1,16 @@ +ocamldoc +ocamldoc.opt +odoc_crc.ml +odoc_lexer.ml +odoc_ocamlhtml.ml +odoc_parser.ml +odoc_parser.mli +odoc_see_lexer.ml +odoc_text_lexer.ml +odoc_text_parser.ml +odoc_text_parser.mli +stdlib_man +*.output +test_stdlib +test_latex +test diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 852df926..d04809aa 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -1,5 +1,5 @@ #(***********************************************************************) -#(* OCamldoc *) +#(* OCamldoc *) #(* *) #(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) #(* *) @@ -47,6 +47,11 @@ INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) ODOC_TEST=odoc_test.cmo +GENERATORS_CMOS= \ + generators/odoc_todo.cmo \ + generators/odoc_literate.cmo +GENERATORS_CMXS=$(GENERATORS_CMOS:.cmo=.cmxs) + # Compilation ############# @@ -72,8 +77,8 @@ COMPFLAGS=$(INCLUDES) -warn-error A LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ - odoc_global.cmo\ odoc_messages.cmo\ + odoc_global.cmo\ odoc_types.cmo\ odoc_misc.cmo\ odoc_text_parser.cmo\ @@ -88,7 +93,6 @@ CMOFILES= odoc_config.cmo \ odoc_module.cmo\ odoc_print.cmo \ odoc_str.cmo\ - odoc_args.cmo\ odoc_comments_global.cmo\ odoc_parser.cmo\ odoc_lexer.cmo\ @@ -121,6 +125,8 @@ EXECMOFILES=$(CMOFILES) \ odoc_latex.cmo \ odoc_texi.cmo \ odoc_dot.cmo \ + odoc_gen.cmo \ + odoc_args.cmo\ odoc.cmo EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) @@ -140,7 +146,6 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/utils/warnings.cmo \ $(OCAMLSRCDIR)/utils/ccomp.cmo \ $(OCAMLSRCDIR)/utils/consistbl.cmo \ - $(OCAMLSRCDIR)/parsing/linenum.cmo\ $(OCAMLSRCDIR)/parsing/location.cmo\ $(OCAMLSRCDIR)/parsing/longident.cmo \ $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \ @@ -188,14 +193,17 @@ STDLIB_MLIS=../stdlib/*.mli \ ../otherlibs/bigarray/bigarray.mli \ ../otherlibs/num/num.mli -all: exe lib manpages +all: exe lib generators manpages exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) +generators: $(GENERATORS_CMOS) -opt.opt: exeopt libopt +opt.opt: exeopt libopt generatorsopt exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) +generatorsopt: $(GENERATORS_CMXS) + debug: make OCAMLPP="" @@ -235,7 +243,7 @@ odoc_see_lexer.ml: odoc_see_lexer.mll # generic rules : ################# -.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx +.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs .ml.cmo: $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< @@ -246,6 +254,9 @@ odoc_see_lexer.ml: odoc_see_lexer.mll .ml.cmx: $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< +.ml.cmxs: + $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $< + .mll.ml: $(OCAMLLEX) $< @@ -282,6 +293,10 @@ installopt_really: test: dummy $(MKDIR) $@ $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli -v + $(MKDIR) $@-custom + $(OCAMLDOC_RUN) -colorize-code -sort -d $@-custom $(INCLUDES) \ + -g generators/odoc_literate.cmo -g generators/odoc_todo.cmo \ + -load $@/ocamldoc.odoc -v test_stdlib: dummy $(MKDIR) $@ @@ -339,6 +354,7 @@ clean:: dummy @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] depend:: $(OCAMLYACC) odoc_text_parser.mly diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 387aec92..a65b5973 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -1,5 +1,5 @@ #(***********************************************************************) -#(* OCamldoc *) +#(* OCamldoc *) #(* *) #(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) #(* *) @@ -66,8 +66,8 @@ COMPFLAGS=$(INCLUDES) LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ - odoc_global.cmo\ odoc_messages.cmo\ + odoc_global.cmo\ odoc_types.cmo\ odoc_misc.cmo\ odoc_text_parser.cmo\ @@ -82,7 +82,6 @@ CMOFILES= odoc_config.cmo \ odoc_module.cmo\ odoc_print.cmo \ odoc_str.cmo\ - odoc_args.cmo\ odoc_comments_global.cmo\ odoc_parser.cmo\ odoc_lexer.cmo\ @@ -115,6 +114,8 @@ EXECMOFILES=$(CMOFILES)\ odoc_latex.cmo\ odoc_texi.cmo\ odoc_dot.cmo\ + odoc_gen.cmo\ + odoc_args.cmo\ odoc.cmo @@ -135,7 +136,6 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/utils/warnings.cmo \ $(OCAMLSRCDIR)/utils/ccomp.cmo \ $(OCAMLSRCDIR)/utils/consistbl.cmo \ - $(OCAMLSRCDIR)/parsing/linenum.cmo\ $(OCAMLSRCDIR)/parsing/location.cmo\ $(OCAMLSRCDIR)/parsing/longident.cmo \ $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \ diff --git a/ocamldoc/generators/odoc_literate.ml b/ocamldoc/generators/odoc_literate.ml new file mode 100644 index 00000000..6a1e0783 --- /dev/null +++ b/ocamldoc/generators/odoc_literate.ml @@ -0,0 +1,207 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Odoc_info +module Naming = Odoc_html.Naming +open Odoc_info.Value +open Odoc_info.Module + +let p = Printf.bprintf +let bp = Printf.bprintf +let bs = Buffer.add_string + +module Html = + (val + ( + match !Odoc_args.current_generator with + None -> (module Odoc_html.Generator : Odoc_html.Html_generator) + | Some (Odoc_gen.Html m) -> m + | _ -> + failwith + "A non-html generator is already set. Cannot install the Todo-list html generator" + ) : Odoc_html.Html_generator) +;; + +module Generator = +struct +class html = + object (self) + inherit Html.html as html + + method private html_of_module_comment b text = + let br1, br2 = + match text with + [(Odoc_info.Title (n, l_opt, t))] -> false, false + | (Odoc_info.Title (n, l_opt, t)) :: _ -> false, true + | _ -> true, true + in + if br1 then p b "
"; + self#html_of_text b text; + if br2 then p b "

\n" + + method private html_of_Title b n l_opt t = + let label1 = self#create_title_label (n, l_opt, t) in + p b "\n" (Naming.label_target label1); + p b "" n; + self#html_of_text b t; + p b "" n + + val mutable code_id = 0 + method private code_block b code = + code_id <- code_id + 1; + Printf.bprintf b + "\"+/-\"/" code_id code_id code_id; + Printf.bprintf b "
" code_id; + self#html_of_code b code; + Printf.bprintf b "
" + + (** Print html code for a value. *) + method private html_of_value b v = + Odoc_info.reset_type_names (); + self#html_of_info b v.val_info; + bs b "
";
+      bs b (self#keyword "val");
+      bs b " ";
+      (* html mark *)
+      bp b "" (Naming.value_target v);
+      bs b (self#escape (Name.simple v.val_name));
+      bs b " : ";
+      self#html_of_type_expr b (Name.father v.val_name) v.val_type;
+      bs b "
"; + ( + if !Odoc_html.with_parameter_list then + self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters + else + self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters + ); + ( + match v.val_code with + None -> () + | Some code -> + self#code_block b code + ) +(* + (** Print html code for a module. *) + method private 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 ((self#keyword "module")^" ");
+      (
+       if with_link then
+         bp b "%s" html_file (Name.simple m.m_name)
+       else
+         bs b (Name.simple m.m_name)
+      );
+(*      A remettre quand on compilera avec ocaml 3.10
+         (
+       match m.m_kind with
+         Module_functor _ when !Odoc_info.Args.html_short_functors  ->
+           ()
+
+       | _ -> *) bs b ": ";
+      (*
+      );
+      *)
+      self#html_of_module_kind b father ~modu: m m.m_kind;
+      bs b "
"; + if info && complete then + self#html_of_info ~indent: false b m.m_info + +*) + initializer + default_style_options <- + ["a:visited {color : #416DFF; text-decoration : none; }" ; + "a:link {color : #416DFF; text-decoration : none;}" ; + "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ; + "a:active {color : Red; text-decoration : underline; }" ; + ".keyword { font-weight : bold ; color : Red }" ; + ".keywordsign { color : #C04600 }" ; + ".superscript { font-size : 4 }" ; + ".subscript { font-size : 4 }" ; + ".comment { color : Green }" ; + ".constructor { color : Blue }" ; + ".type { color : #5C6585 }" ; + ".string { color : Maroon }" ; + ".warning { color : Red ; font-weight : bold }" ; + ".info { margin-top: 8px; }"; + ".param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }" ; + ".code { color : #465F91 ; }" ; + "h1 { font-size : 20pt ; text-align: center; }" ; + + "h2 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90BDFF ;"^ + "padding: 2px; }" ; + + "h3 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90DDFF ;"^ + "padding: 2px; }" ; + + "h4 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90EDFF ;"^ + "padding: 2px; }" ; + + "h5 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90FDFF ;"^ + "padding: 2px; }" ; + + "h6 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #C0FFFF ; "^ + "padding: 2px; }" ; + + "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #E0FFFF ; "^ + "padding: 2px; }" ; + + "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #F0FFFF ; "^ + "padding: 2px; }" ; + + "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #FFFFFF ; "^ + "padding: 2px; }" ; + + ".typetable { border-style : hidden }" ; + ".indextable { border-style : hidden }" ; + ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ; + "body { background-color : White }" ; + "tr { background-color : White }" ; + "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ; + "pre { margin-bottom: 4px ; margin-left: 1em; "^ + "border-color: #27408b; border-style: solid; "^ + "border-width: 1px 1px 1px 3px; "^ + "padding: 4px; }" ; + "div.sig_block {margin-left: 2em}" ; + + "div.codeblock { "^ + "margin-left: 2em; margin-right: 1em; padding: 6px; "^ + "margin-bottom: 8px; display: none; "^ + "border-width: 1px 1px 1px 3px; border-style: solid; border-color: grey; }" ; + + "span.code_expand { color: blue; text-decoration: underline; cursor: pointer; "^ + "margin-left: 1em ; } "; + ]; + end +end + +let _ = Odoc_args.set_generator + (Odoc_gen.Html (module Generator : Odoc_html.Html_generator)) + ;; diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml new file mode 100644 index 00000000..7c025e12 --- /dev/null +++ b/ocamldoc/generators/odoc_todo.ml @@ -0,0 +1,225 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, projet Cristal, 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** An OCamldoc generator to retrieve information in "todo" tags and + generate an html page with all todo items. *) + +open Odoc_info +module Naming = Odoc_html.Naming +open Odoc_info.Value +open Odoc_info.Module +open Odoc_info.Type +open Odoc_info.Exception +open Odoc_info.Class + +let p = Printf.bprintf + +module Html = + (val + ( + match !Odoc_args.current_generator with + None -> (module Odoc_html.Generator : Odoc_html.Html_generator) + | Some (Odoc_gen.Html m) -> m + | _ -> + failwith + "A non-html generator is already set. Cannot install the Todo-list html generator" + ) : Odoc_html.Html_generator) +;; + +module Generator = +struct + class scanner html = + object (self) + inherit Odoc_info.Scan.scanner + + val b = Buffer.create 256 + method buffer = b + + method private gen_if_tag name target info_opt = + match info_opt with + None -> () + | Some i -> + let l = + List.fold_left + (fun acc (t, text) -> + match t with + "todo" -> + begin + match text with + (Odoc_info.Code s) :: q -> + ( + try + let n = int_of_string s in + let head = + Odoc_info.Code (Printf.sprintf "[%d] " n) + in + (Some n, head::q) :: acc + with _ -> (None, text) :: acc + ) + | _ -> (None, text) :: acc + + end + | _ -> acc + ) + [] + i.i_custom + in + match l with + [] -> () + | _ -> + let l = List.sort + (fun a b -> + match a, b with + (None, _), _ -> -1 + | _, (None, _) -> 1 + | (Some n1, _), (Some n2, _) -> compare n1 n2 + ) + l + in + p b "
%s
" + target name; + let col = function + None -> "#000000" + | Some 1 -> "#FF0000" + | Some 2 -> "#AA5555" + | Some 3 -> "#44BB00" + | Some n -> Printf.sprintf "#%2x0000" (0xAA - (n * 0x10)) + in + List.iter + (fun (n, e) -> + Printf.bprintf b "" (col n); + html#html_of_text b e; + p b "
\n"; + ) + l; + p b "
" + + method scan_value v = + self#gen_if_tag + v.val_name + (Odoc_html.Naming.complete_value_target v) + v.val_info + + method scan_type t = + self#gen_if_tag + t.ty_name + (Odoc_html.Naming.complete_type_target t) + t.ty_info + + method scan_exception e = + self#gen_if_tag + e.ex_name + (Odoc_html.Naming.complete_exception_target e) + e.ex_info + + method scan_attribute a = + self#gen_if_tag + a.att_value.val_name + (Odoc_html.Naming.complete_attribute_target a) + a.att_value.val_info + + method scan_method m = + self#gen_if_tag + m.met_value.val_name + (Odoc_html.Naming.complete_method_target m) + m.met_value.val_info + + (** This method scan the elements of the given module. *) + method scan_module_elements m = + List.iter + (fun ele -> + match ele with + Odoc_module.Element_module m -> self#scan_module m + | Odoc_module.Element_module_type mt -> self#scan_module_type mt + | Odoc_module.Element_included_module im -> self#scan_included_module im + | Odoc_module.Element_class c -> self#scan_class c + | Odoc_module.Element_class_type ct -> self#scan_class_type ct + | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_exception e -> self#scan_exception e + | Odoc_module.Element_type t -> self#scan_type t + | Odoc_module.Element_module_comment t -> self#scan_module_comment t + ) + (Odoc_module.module_elements ~trans: false m) + + method scan_included_module _ = () + + method scan_class_pre c = + self#gen_if_tag + c.cl_name + (fst (Odoc_html.Naming.html_files c.cl_name)) + c.cl_info; + true + + method scan_class_type_pre ct = + self#gen_if_tag + ct.clt_name + (fst (Odoc_html.Naming.html_files ct.clt_name)) + ct.clt_info; + true + + method scan_module_pre m = + self#gen_if_tag + m.m_name + (fst (Odoc_html.Naming.html_files m.m_name)) + m.m_info; + true + + method scan_module_type_pre mt = + self#gen_if_tag + mt.mt_name + (fst (Odoc_html.Naming.html_files mt.mt_name)) + mt.mt_info; + true + end + + class html : Html.html = + object (self) + inherit Html.html as html + + (** we have to hack a little because we cannot inherit from + scanner, since public method cannot be hidden and + our html class must respect the type of the default + html generator class *) + val mutable scanner = new scanner (new Html.html ) + + method generate modules = + (* prevent having the 'todo' tag signaled as not handled *) + tag_functions <- ("todo", (fun _ -> "")) :: tag_functions; + (* generate doc as usual *) + html#generate modules; + (* then retrieve the todo tags and generate the todo.html page *) + let title = + match !Odoc_info.Global.title with + None -> "" + | Some s -> s + in + let b = Buffer.create 512 in + p b ""; + self#print_header b title ; + p b "

%s

" title; + scanner#scan_module_list modules; + Buffer.add_buffer b scanner#buffer; + let oc = open_out + (Filename.concat !Odoc_info.Global.target_dir "todo.html") + in + Buffer.output_buffer oc b; + close_out oc + + initializer + scanner <- new scanner self + end +end + +let _ = Odoc_args.set_generator + (Odoc_gen.Html (module Generator : Odoc_html.Html_generator)) + ;; diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva index 454cee9e..1d0eb60d 100644 --- a/ocamldoc/ocamldoc.hva +++ b/ocamldoc/ocamldoc.hva @@ -1,3 +1,14 @@ +%(***********************************************************************) +%(* OCamldoc *) +%(* *) +%(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) +%(* *) +%(* Copyright 2001 Institut National de Recherche en Informatique et *) +%(* en Automatique. All rights reserved. This file is distributed *) +%(* under the terms of the Q Public License version 1.0. *) +%(* *) +%(***********************************************************************) + \usepackage{alltt} \newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}} \newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}} diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index 5ecf7051..54b84db9 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -11,7 +11,8 @@ (* $Id$ *) -(** Main module for bytecode. *) +(** Main module for bytecode. +@todo coucou le todo*) open Config open Clflags @@ -25,21 +26,20 @@ let print_DEBUG s = print_string s ; print_newline () (* we check if we must load a module given on the command line *) let arg_list = Array.to_list Sys.argv -let (cm_opt, paths) = - let rec iter (f_opt, inc) = function - [] | _ :: [] -> (f_opt, inc) +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 "cmxs")) & - (f_opt = None) -> - iter (Some file, inc) q + (Filename.check_suffix file "cmxs")) -> + iter (file :: files, incs) q | "-i" :: dir :: q -> - iter (f_opt, inc @ [dir]) q + iter (files, dir :: incs) q | _ :: q -> - iter (f_opt, inc) q + iter (files, incs) q in - iter (None, []) arg_list + iter ([], []) arg_list let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load" @@ -63,41 +63,29 @@ let get_real_filename name = failwith (M.file_not_found_in_paths paths name) ) -let _ = - match cm_opt with - None -> - () - | Some file -> - let file = Dynlink.adapt_filename file in - Dynlink.allow_unsafe_modules true; - try - let real_file = get_real_filename file in - ignore(Dynlink.loadfile real_file) - with - Dynlink.Error e -> - prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ; - exit 1 - | Not_found -> - prerr_endline (Odoc_messages.load_file_error file "Not_found"); - exit 1 - | Sys_error s - | Failure s -> - prerr_endline (Odoc_messages.load_file_error file s); - exit 1 - -let _ = print_DEBUG "Fin du chargement dynamique eventuel" - -let default_html_generator = new Odoc_html.html -let default_latex_generator = new Odoc_latex.latex -let default_texi_generator = new Odoc_texi.texi -let default_man_generator = new Odoc_man.man -let default_dot_generator = new Odoc_dot.dot -let _ = Odoc_args.parse - (default_html_generator :> Odoc_args.doc_generator) - (default_latex_generator :> Odoc_args.doc_generator) - (default_texi_generator :> Odoc_args.doc_generator) - (default_man_generator :> Odoc_args.doc_generator) - (default_dot_generator :> Odoc_args.doc_generator) +let load_plugin file = + let file = Dynlink.adapt_filename file in + Dynlink.allow_unsafe_modules true; + try + let real_file = get_real_filename file in + ignore(Dynlink.loadfile real_file) + with + Dynlink.Error e -> + prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ; + exit 1 + | Not_found -> + prerr_endline (Odoc_messages.load_file_error file "Not_found"); + exit 1 + | Sys_error s + | Failure s -> + prerr_endline (Odoc_messages.load_file_error file s); + exit 1 +;; +List.iter load_plugin plugins;; + +let () = print_DEBUG "Fin du chargement dynamique eventuel" + +let () = Odoc_args.parse () let loaded_modules = @@ -114,13 +102,13 @@ let loaded_modules = incr Odoc_global.errors ; [] ) - !Odoc_args.load + !Odoc_global.load ) -let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files +let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_global.files let _ = - match !Odoc_args.dump with + match !Odoc_global.dump with None -> () | Some f -> try Odoc_analyse.dump_modules f modules @@ -128,13 +116,15 @@ let _ = prerr_endline s ; incr Odoc_global.errors + let _ = - match !Odoc_args.doc_generator with + match !Odoc_args.current_generator with None -> () | Some gen -> + let generator = Odoc_gen.get_minimal_generator gen in Odoc_info.verbose Odoc_messages.generating_doc; - gen#generate modules; + generator#generate modules; Odoc_info.verbose Odoc_messages.ok let _ = diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 143da019..bbcfaf93 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -73,15 +73,14 @@ let parse_file inputfile parse_fun ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); + 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" + fatal_error "OCaml and preprocessor have incompatible versions" | _ -> false in let ast = @@ -203,18 +202,18 @@ let process_error exn = (** Process the given file, according to its extension. Return the Module.t created, if any.*) let process_file ppf sourcefile = - if !Odoc_args.verbose then + if !Odoc_global.verbose then ( let f = match sourcefile with - Odoc_args.Impl_file f - | Odoc_args.Intf_file f -> f - | Odoc_args.Text_file f -> f + Odoc_global.Impl_file f + | Odoc_global.Intf_file f -> f + | Odoc_global.Text_file f -> f in print_string (Odoc_messages.analysing f) ; print_newline (); ); match sourcefile with - Odoc_args.Impl_file file -> + Odoc_global.Impl_file file -> ( Location.input_name := file; try @@ -228,7 +227,7 @@ let process_file ppf sourcefile = in file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ; - if !Odoc_args.verbose then + if !Odoc_global.verbose then ( print_string Odoc_messages.ok; print_newline () @@ -246,7 +245,7 @@ let process_file ppf sourcefile = incr Odoc_global.errors ; None ) - | Odoc_args.Intf_file file -> + | Odoc_global.Intf_file file -> ( Location.input_name := file; try @@ -257,7 +256,7 @@ let process_file ppf sourcefile = file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ; - if !Odoc_args.verbose then + if !Odoc_global.verbose then ( print_string Odoc_messages.ok; print_newline () @@ -275,7 +274,7 @@ let process_file ppf sourcefile = incr Odoc_global.errors ; None ) - | Odoc_args.Text_file file -> + | Odoc_global.Text_file file -> Location.input_name := file; try let mod_name = @@ -474,20 +473,20 @@ let analyse_files ?(init=[]) files = in (* Remove elements between the stop special comments, if needed. *) let modules = - if !Odoc_args.no_stop then + if !Odoc_global.no_stop then modules_pre else remove_elements_between_stop modules_pre in - if !Odoc_args.verbose then + if !Odoc_global.verbose then ( print_string Odoc_messages.merging; print_newline () ); - let merged_modules = Odoc_merge.merge !Odoc_args.merge_options modules in - if !Odoc_args.verbose then + let merged_modules = Odoc_merge.merge !Odoc_global.merge_options modules in + if !Odoc_global.verbose then ( print_string Odoc_messages.ok; print_newline (); @@ -499,20 +498,20 @@ let analyse_files ?(init=[]) files = merged_modules ) in - if !Odoc_args.verbose then + if !Odoc_global.verbose then ( print_string Odoc_messages.cross_referencing; print_newline () ); let _ = Odoc_cross.associate modules_list in - if !Odoc_args.verbose then + if !Odoc_global.verbose then ( print_string Odoc_messages.ok; print_newline (); ); - if !Odoc_args.sort_modules then + if !Odoc_global.sort_modules then Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules else merged_modules diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli index e9be5ba5..b927ad4a 100644 --- a/ocamldoc/odoc_analyse.mli +++ b/ocamldoc/odoc_analyse.mli @@ -19,7 +19,7 @@ *) val analyse_files : ?init: Odoc_module.t_module list -> - Odoc_args.source_file list -> + Odoc_global.source_file list -> Odoc_module.t_module list (** Dump of a list of modules into a file. diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index fa693d69..bee38930 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -13,40 +13,99 @@ (** Command-line arguments. *) -open Clflags - module M = Odoc_messages -type source_file = - Impl_file of string - | Intf_file of string - | Text_file of string - -let include_dirs = Clflags.include_dirs - -class type doc_generator = - object - method generate : Odoc_module.t_module list -> unit - end - -let doc_generator = ref (None : doc_generator option) - -let merge_options = ref ([] : Odoc_types.merge_option list) - -let out_file = ref M.default_out_file - -let dot_include_all = ref false - -let dot_types = ref false - -let dot_reduce = ref false - -let dot_colors = ref (List.flatten M.default_dot_colors) - -let man_suffix = ref M.default_man_suffix -let man_section = ref M.default_man_section - -let man_mini = ref false +let current_generator = ref (None : Odoc_gen.generator option) + +let get_html_generator () = + match !current_generator with + None -> (module Odoc_html.Generator : Odoc_html.Html_generator) + | Some (Odoc_gen.Html m) -> m + | Some _ -> failwith (M.current_generator_is_not "html") +;; + +let get_latex_generator () = + match !current_generator with + None -> (module Odoc_latex.Generator : Odoc_latex.Latex_generator) + | Some (Odoc_gen.Latex m) -> m + | Some _ -> failwith (M.current_generator_is_not "latex") +;; + +let get_texi_generator () = + match !current_generator with + None -> (module Odoc_texi.Generator : Odoc_texi.Texi_generator) + | Some (Odoc_gen.Texi m) -> m + | Some _ -> failwith (M.current_generator_is_not "texi") +;; + +let get_man_generator () = + match !current_generator with + None -> (module Odoc_man.Generator : Odoc_man.Man_generator) + | Some (Odoc_gen.Man m) -> m + | Some _ -> failwith (M.current_generator_is_not "man") +;; + +let get_dot_generator () = + match !current_generator with + None -> (module Odoc_dot.Generator : Odoc_dot.Dot_generator) + | Some (Odoc_gen.Dot m) -> m + | Some _ -> failwith (M.current_generator_is_not "dot") +;; + +let get_base_generator () = + match !current_generator with + None -> (module Odoc_gen.Base_generator : Odoc_gen.Base) + | Some (Odoc_gen.Base m) -> m + | Some _ -> failwith (M.current_generator_is_not "base") +;; + +let extend_html_generator f = + let current = get_html_generator () in + let module Current = (val current : Odoc_html.Html_generator) in + let module F = (val f : Odoc_gen.Html_functor) in + let module M = F(Current) in + current_generator := Some (Odoc_gen.Html (module M : Odoc_html.Html_generator)) +;; + +let extend_latex_generator f = + let current = get_latex_generator () in + let module Current = (val current : Odoc_latex.Latex_generator) in + let module F = (val f : Odoc_gen.Latex_functor) in + let module M = F(Current) in + current_generator := Some(Odoc_gen.Latex (module M : Odoc_latex.Latex_generator)) +;; + +let extend_texi_generator f = + let current = get_texi_generator () in + let module Current = (val current : Odoc_texi.Texi_generator) in + let module F = (val f : Odoc_gen.Texi_functor) in + let module M = F(Current) in + current_generator := Some(Odoc_gen.Texi (module M : Odoc_texi.Texi_generator)) +;; + +let extend_man_generator f = + let current = get_man_generator () in + let module Current = (val current : Odoc_man.Man_generator) in + let module F = (val f : Odoc_gen.Man_functor) in + let module M = F(Current) in + current_generator := Some(Odoc_gen.Man (module M : Odoc_man.Man_generator)) +;; + +let extend_dot_generator f = + let current = get_dot_generator () in + let module Current = (val current : Odoc_dot.Dot_generator) in + let module F = (val f : Odoc_gen.Dot_functor) in + let module M = F(Current) in + current_generator := Some (Odoc_gen.Dot (module M : Odoc_dot.Dot_generator)) +;; + +let extend_base_generator f = + let current = get_base_generator () in + let module Current = (val current : Odoc_gen.Base) in + let module F = (val f : Odoc_gen.Base_functor) in + let module M = F(Current) in + current_generator := Some (Odoc_gen.Base (module M : Odoc_gen.Base)) +;; (** Analysis of a string defining options. Return the list of options according to the list giving associations between @@ -81,79 +140,6 @@ let analyse_merge_options s = in analyse_option_string l s -let classic = Clflags.classic - -let dump = ref (None : string option) - -let load = ref ([] : string list) - -(** Allow arbitrary recursive types. *) -let recursive_types = Clflags.recursive_types - -let verbose = ref false - -(** Optional preprocessor command. *) -let preprocessor = Clflags.preprocessor - -let sort_modules = ref false - -let no_custom_tags = ref false - -let no_stop = ref false - -let remove_stars = ref false - -let keep_code = ref false - -let inverse_merge_ml_mli = ref false - -let filter_with_module_constraints = ref true - -let title = ref (None : string option) - -let intro_file = ref (None : string option) - -let with_parameter_list = ref false - -let hidden_modules = ref ([] : string list) - -let target_dir = ref Filename.current_dir_name - -let css_style = ref None - -let index_only = ref false - -let colorize_code = ref false - -let html_short_functors = ref false - -let charset = ref "iso-8859-1" - -let with_header = ref true - -let with_trailer = ref true - -let separate_files = ref false - -let latex_titles = ref [ - 1, "section" ; - 2, "subsection" ; - 3, "subsubsection" ; - 4, "paragraph" ; - 5, "subparagraph" ; -] - -let with_toc = ref true - -let with_index = ref true - -let esc_8bits = ref false - -let info_section = ref "Objective Caml" - -let info_entry = ref [] - -let files = ref [] let f_latex_title s = try @@ -161,8 +147,8 @@ let f_latex_title s = let n = int_of_string (String.sub s 0 pos) in let len = String.length s in let command = String.sub s (pos + 1) (len - pos - 1) in - latex_titles := List.remove_assoc n !latex_titles ; - latex_titles := (n, command) :: !latex_titles + Odoc_latex.latex_titles := List.remove_assoc n !Odoc_latex.latex_titles ; + Odoc_latex.latex_titles := (n, command) :: !Odoc_latex.latex_titles with Not_found | Invalid_argument _ -> @@ -178,83 +164,77 @@ let add_hidden_modules s = "" -> () | _ -> match name.[0] with - 'A'..'Z' -> hidden_modules := name :: !hidden_modules + 'A'..'Z' -> Odoc_global.hidden_modules := name :: !Odoc_global.hidden_modules | _ -> incr Odoc_global.errors; prerr_endline (M.not_a_module_name name) ) l -let latex_value_prefix = ref M.default_latex_value_prefix -let latex_type_prefix = ref M.default_latex_type_prefix -let latex_exception_prefix = ref M.default_latex_exception_prefix -let latex_module_prefix = ref M.default_latex_module_prefix -let latex_module_type_prefix = ref M.default_latex_module_type_prefix -let latex_class_prefix = ref M.default_latex_class_prefix -let latex_class_type_prefix = ref M.default_latex_class_type_prefix -let latex_attribute_prefix = ref M.default_latex_attribute_prefix -let latex_method_prefix = ref M.default_latex_method_prefix - -let set_doc_generator (dg_opt : doc_generator option) = doc_generator := dg_opt - -(** The default html generator. Initialized in the parse function, to be used during the command line analysis.*) -let default_html_generator = ref (None : doc_generator option) - -(** The default latex generator. Initialized in the parse function, to be used during the command line analysis.*) -let default_latex_generator = ref (None : doc_generator option) - -(** The default texinfo generator. Initialized in the parse function, to be used during the command line analysis.*) -let default_texi_generator = ref (None : doc_generator option) - -(** The default man pages generator. Initialized in the parse function, to be used during the command line analysis.*) -let default_man_generator = ref (None : doc_generator option) - -(** The default dot generator. Initialized in the parse function, to be used during the command line analysis.*) -let default_dot_generator = ref (None : doc_generator option) +let set_generator (g : Odoc_gen.generator) = current_generator := Some g (** The default option list *) let default_options = [ "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ; "-vnum", Arg.Unit (fun () -> print_string M.config_version ; print_newline () ; exit 0) , M.option_version ; - "-v", Arg.Unit (fun () -> verbose := true), M.verbose_mode ; - "-I", Arg.String (fun s -> include_dirs := (Misc.expand_directory Config.standard_library s) :: !include_dirs), M.include_dirs ; - "-pp", Arg.String (fun s -> preprocessor := Some s), M.preprocess ; - "-impl", Arg.String (fun s -> files := !files @ [Impl_file s]), M.option_impl ; - "-intf", Arg.String (fun s -> files := !files @ [Intf_file s]), M.option_intf ; - "-text", Arg.String (fun s -> files := !files @ [Text_file s]), M.option_text ; - "-rectypes", Arg.Set recursive_types, M.rectypes ; - "-nolabels", Arg.Unit (fun () -> classic := true), M.nolabels ; + "-v", Arg.Unit (fun () -> Odoc_global.verbose := true), M.verbose_mode ; + "-I", Arg.String (fun s -> + Odoc_global.include_dirs := + (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 ; + "-impl", Arg.String (fun s -> + Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]), + M.option_impl ; + "-intf", Arg.String (fun s -> + Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]), + M.option_intf ; + "-text", Arg.String (fun s -> + Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]), + M.option_text ; + "-rectypes", Arg.Set Odoc_global.recursive_types, M.rectypes ; + "-nolabels", Arg.Unit (fun () -> Odoc_global.classic := true), M.nolabels ; "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ; "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ; - "-o", Arg.String (fun s -> out_file := s), M.out_file ; - "-d", Arg.String (fun s -> target_dir := s), M.target_dir ; - "-sort", Arg.Unit (fun () -> sort_modules := true), M.sort_modules ; - "-no-stop", Arg.Set no_stop, M.no_stop ; - "-no-custom-tags", Arg.Set no_custom_tags, M.no_custom_tags ; - "-stars", Arg.Set remove_stars, M.remove_stars ; - "-inv-merge-ml-mli", Arg.Set inverse_merge_ml_mli, M.inverse_merge_ml_mli ; - "-no-module-constraint-filter", Arg.Clear filter_with_module_constraints, + "-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ; + "-d", Arg.String (fun s -> Odoc_global.target_dir := s), M.target_dir ; + "-sort", Arg.Unit (fun () -> Odoc_global.sort_modules := true), M.sort_modules ; + "-no-stop", Arg.Set Odoc_global.no_stop, M.no_stop ; + "-no-custom-tags", Arg.Set Odoc_global.no_custom_tags, M.no_custom_tags ; + "-stars", Arg.Set Odoc_global.remove_stars, M.remove_stars ; + "-inv-merge-ml-mli", Arg.Set Odoc_global.inverse_merge_ml_mli, M.inverse_merge_ml_mli ; + "-no-module-constraint-filter", Arg.Clear Odoc_global.filter_with_module_constraints, M.no_filter_with_module_constraints ; - "-keep-code", Arg.Set keep_code, M.keep_code^"\n" ; + "-keep-code", Arg.Set Odoc_global.keep_code, M.keep_code^"\n" ; - "-dump", Arg.String (fun s -> dump := Some s), M.dump ; - "-load", Arg.String (fun s -> load := !load @ [s]), M.load^"\n" ; + "-dump", Arg.String (fun s -> Odoc_global.dump := Some s), M.dump ; + "-load", Arg.String (fun s -> Odoc_global.load := !Odoc_global.load @ [s]), M.load^"\n" ; - "-t", Arg.String (fun s -> title := Some s), M.option_title ; - "-intro", Arg.String (fun s -> intro_file := Some s), M.option_intro ; + "-t", Arg.String (fun s -> Odoc_global.title := Some s), M.option_title ; + "-intro", Arg.String (fun s -> Odoc_global.intro_file := Some s), M.option_intro ; "-hide", Arg.String add_hidden_modules, M.hide_modules ; - "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), + "-m", Arg.String (fun s -> Odoc_global.merge_options := !Odoc_global.merge_options @ (analyse_merge_options s)), M.merge_options ^ "\n\n *** choosing a generator ***\n"; (* generators *) - "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), M.generate_html ; - "-latex", Arg.Unit (fun () -> set_doc_generator !default_latex_generator), M.generate_latex ; - "-texi", Arg.Unit (fun () -> set_doc_generator !default_texi_generator), M.generate_texinfo ; - "-man", Arg.Unit (fun () -> set_doc_generator !default_man_generator), M.generate_man ; - "-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), M.generate_dot ; + "-html", Arg.Unit (fun () -> set_generator + (Odoc_gen.Html (module Odoc_html.Generator : Odoc_html.Html_generator))), + M.generate_html ; + "-latex", Arg.Unit (fun () -> set_generator + (Odoc_gen.Latex (module Odoc_latex.Generator : Odoc_latex.Latex_generator))), + M.generate_latex ; + "-texi", Arg.Unit (fun () -> set_generator + (Odoc_gen.Texi (module Odoc_texi.Generator : Odoc_texi.Texi_generator))), + M.generate_texinfo ; + "-man", Arg.Unit (fun () -> set_generator + (Odoc_gen.Man (module Odoc_man.Generator : Odoc_man.Man_generator))), + M.generate_man ; + "-dot", Arg.Unit (fun () -> set_generator + (Odoc_gen.Dot (module Odoc_dot.Generator : Odoc_dot.Dot_generator))), + M.generate_dot ; "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0), M.display_custom_generators_dir ; "-i", Arg.String (fun s -> ()), M.add_load_dir ; @@ -262,51 +242,59 @@ let default_options = [ "\n\n *** HTML options ***\n"; (* html only options *) - "-all-params", Arg.Set with_parameter_list, M.with_parameter_list ; - "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ; - "-index-only", Arg.Set index_only, M.index_only ; - "-colorize-code", Arg.Set colorize_code, M.colorize_code ; - "-short-functors", Arg.Set html_short_functors, M.html_short_functors ; - "-charset", Arg.Set_string charset, (M.charset !charset)^ + "-all-params", Arg.Set Odoc_html.with_parameter_list, M.with_parameter_list ; + "-css-style", Arg.String (fun s -> Odoc_html.css_style := Some s), M.css_style ; + "-index-only", Arg.Set Odoc_html.index_only, M.index_only ; + "-colorize-code", Arg.Set Odoc_html.colorize_code, M.colorize_code ; + "-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ; + "-charset", Arg.Set_string Odoc_html.charset, (M.charset !Odoc_html.charset)^ "\n\n *** LaTeX options ***\n"; (* latex only options *) - "-noheader", Arg.Unit (fun () -> with_header := false), M.no_header ; - "-notrailer", Arg.Unit (fun () -> with_trailer := false), M.no_trailer ; - "-sepfiles", Arg.Set separate_files, M.separate_files ; - "-latextitle", Arg.String f_latex_title, M.latex_title latex_titles ; - "-latex-value-prefix", Arg.String (fun s -> latex_value_prefix := s), M.latex_value_prefix ; - "-latex-type-prefix", Arg.String (fun s -> latex_type_prefix := s), M.latex_type_prefix ; - "-latex-exception-prefix", Arg.String (fun s -> latex_exception_prefix := s), M.latex_exception_prefix ; - "-latex-attribute-prefix", Arg.String (fun s -> latex_attribute_prefix := s), M.latex_attribute_prefix ; - "-latex-method-prefix", Arg.String (fun s -> latex_method_prefix := s), M.latex_method_prefix ; - "-latex-module-prefix", Arg.String (fun s -> latex_module_prefix := s), M.latex_module_prefix ; - "-latex-module-type-prefix", Arg.String (fun s -> latex_module_type_prefix := s), M.latex_module_type_prefix ; - "-latex-class-prefix", Arg.String (fun s -> latex_class_prefix := s), M.latex_class_prefix ; - "-latex-class-type-prefix", Arg.String (fun s -> latex_class_type_prefix := s), M.latex_class_type_prefix ; - "-notoc", Arg.Unit (fun () -> with_toc := false), - M.no_toc ^ + "-noheader", Arg.Unit (fun () -> Odoc_global.with_header := false), M.no_header ; + "-notrailer", Arg.Unit (fun () -> Odoc_global.with_trailer := false), M.no_trailer ; + "-sepfiles", Arg.Set Odoc_latex.separate_files, M.separate_files ; + "-latextitle", Arg.String f_latex_title, M.latex_title Odoc_latex.latex_titles ; + "-latex-value-prefix", + Arg.String (fun s -> Odoc_latex.latex_value_prefix := s), M.latex_value_prefix ; + "-latex-type-prefix", + Arg.String (fun s -> Odoc_latex.latex_type_prefix := s), M.latex_type_prefix ; + "-latex-exception-prefix", + Arg.String (fun s -> Odoc_latex.latex_exception_prefix := s), M.latex_exception_prefix ; + "-latex-attribute-prefix", + Arg.String (fun s -> Odoc_latex.latex_attribute_prefix := s), M.latex_attribute_prefix ; + "-latex-method-prefix", + Arg.String (fun s -> Odoc_latex.latex_method_prefix := s), M.latex_method_prefix ; + "-latex-module-prefix", + Arg.String (fun s -> Odoc_latex.latex_module_prefix := s), M.latex_module_prefix ; + "-latex-module-type-prefix", + Arg.String (fun s -> Odoc_latex.latex_module_type_prefix := s), M.latex_module_type_prefix ; + "-latex-class-prefix", + Arg.String (fun s -> Odoc_latex.latex_class_prefix := s), M.latex_class_prefix ; + "-latex-class-type-prefix", + Arg.String (fun s -> Odoc_latex.latex_class_type_prefix := s), M.latex_class_type_prefix ; + "-notoc", Arg.Unit (fun () -> Odoc_global.with_toc := false), M.no_toc ^ "\n\n *** texinfo options ***\n"; -(* tex only options *) - "-noindex", Arg.Clear with_index, M.no_index ; - "-esc8", Arg.Set esc_8bits, M.esc_8bits ; - "-info-section", Arg.String ((:=) info_section), M.info_section ; - "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), +(* texi only options *) + "-noindex", Arg.Clear Odoc_global.with_index, M.no_index ; + "-esc8", Arg.Set Odoc_texi.esc_8bits, M.esc_8bits ; + "-info-section", Arg.String ((:=) Odoc_texi.info_section), M.info_section ; + "-info-entry", Arg.String (fun s -> Odoc_texi.info_entry := !Odoc_texi.info_entry @ [ s ]), M.info_entry ^ "\n\n *** dot options ***\n"; (* dot only options *) - "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ; - "-dot-include-all", Arg.Set dot_include_all, M.dot_include_all ; - "-dot-types", Arg.Set dot_types, M.dot_types ; - "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce^ + "-dot-colors", Arg.String (fun s -> Odoc_dot.dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ; + "-dot-include-all", Arg.Set Odoc_dot.dot_include_all, M.dot_include_all ; + "-dot-types", Arg.Set Odoc_dot.dot_types, M.dot_types ; + "-dot-reduce", Arg.Set Odoc_dot.dot_reduce, M.dot_reduce^ "\n\n *** man pages options ***\n"; (* man only options *) - "-man-mini", Arg.Set man_mini, M.man_mini ; - "-man-suffix", Arg.String (fun s -> man_suffix := s), M.man_suffix ; - "-man-section", Arg.String (fun s -> man_section := s), M.man_section ; + "-man-mini", Arg.Set Odoc_man.man_mini, M.man_mini ; + "-man-suffix", Arg.String (fun s -> Odoc_man.man_suffix := s), M.man_suffix ; + "-man-section", Arg.String (fun s -> Odoc_man.man_section := s), M.man_section ; ] @@ -327,7 +315,7 @@ let help_action () = let msg = Arg.usage_string (!options @ !help_options) - (M.usage ^ M.options_are) in + (M.usage ^ M.options_are) in print_string msg let () = help_options := [ @@ -349,27 +337,22 @@ let add_option o = in options := iter !options -let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_generator = +let parse () = let anonymous f = let sf = if Filename.check_suffix f "ml" then - Impl_file f + Odoc_global.Impl_file f else if Filename.check_suffix f "mli" then - Intf_file f + Odoc_global.Intf_file f else if Filename.check_suffix f "txt" then - Text_file f + Odoc_global.Text_file f else failwith (Odoc_messages.unknown_extension f) in - files := !files @ [sf] + Odoc_global.files := !Odoc_global.files @ [sf] in - default_html_generator := Some html_generator ; - default_latex_generator := Some latex_generator ; - default_texi_generator := Some texi_generator ; - default_man_generator := Some man_generator ; - default_dot_generator := Some dot_generator ; if modified_options () then append_last_doc "\n"; let options = !options @ !help_options in let _ = Arg.parse options @@ -379,4 +362,5 @@ let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_g (* we sort the hidden modules by name, to be sure that for example, A.B is before A, so we will match against A.B before A in Odoc_name.hide_modules.*) - hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !hidden_modules + Odoc_global.hidden_modules := + List.sort (fun a -> fun b -> - (compare a b)) !Odoc_global.hidden_modules diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index b2c8cd00..1d55de74 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -13,183 +13,39 @@ (** Analysis of the command line arguments. *) -(** The kind of source file in arguments. *) -type source_file = - Impl_file of string - | Intf_file of string - | Text_file of string +(** The current module defining the generator to use. *) +val current_generator : Odoc_gen.generator option ref -(** The include_dirs in the OCaml compiler. *) -val include_dirs : string list ref - -(** The class type of documentation generators. *) -class type doc_generator = - object method generate : Odoc_module.t_module list -> unit end - -(** The function to be used to create a generator. *) -val doc_generator : doc_generator option ref - -(** The merge options to be used. *) -val merge_options : Odoc_types.merge_option list ref - -(** Classic mode or not. *) -val classic : bool ref - -(** The file used by the generators outputting only one file. *) -val out_file : string ref - -(** The optional file name to dump the collected information into.*) -val dump : string option ref - -(** The list of information files to load. *) -val load : string list ref - -(** Verbose mode or not. *) -val verbose : bool ref - -(** We must sort the list of top modules or not.*) -val sort_modules : bool ref - -(** We must not stop at the stop special comments. Default is false (we stop).*) -val no_stop : bool ref - -(** We must raise an exception when we find an unknown @-tag. *) -val no_custom_tags : bool ref - -(** We must remove the the first characters of each comment line, until the first asterisk '*'. *) -val remove_stars : bool ref - -(** To keep the code while merging, when we have both .ml and .mli files for a module. *) -val keep_code : bool ref - -(** To inverse implementation and interface files when merging. *) -val inverse_merge_ml_mli : bool ref - -(** To filter module elements according to module type constraints. *) -val filter_with_module_constraints : bool ref - -(** The optional title to use in the generated documentation. *) -val title : string option ref - -(** The optional file whose content can be used as intro text. *) -val intro_file : string option ref - -(** Flag to indicate whether we must display the complete list of parameters - for functions and methods. *) -val with_parameter_list : bool ref - -(** The list of module names to hide. *) -val hidden_modules : string list ref - -(** The directory where files have to be generated. *) -val target_dir : string ref - -(** An optional file to use where a CSS style is defined (for HTML). *) -val css_style : string option ref - -(** Generate only index files. (for HTML). *) -val index_only : bool ref - -(** To colorize code in HTML generated documentation pages, not code pages. *) -val colorize_code : bool ref - -(** To display functors in short form rather than with "functor ... -> ", - in HTML generated documentation. *) -val html_short_functors : bool ref - -(** Encoding used in HTML pages header. *) -val charset : string ref - -(** The flag which indicates if we must generate a header (for LaTeX). *) -val with_header : bool ref - -(** The flag which indicates if we must generate a trailer (for LaTeX). *) -val with_trailer : bool ref - -(** The flag to indicate if we must generate one file per module (for LaTeX). *) -val separate_files : bool ref - -(** The list of pairs (title level, sectionning style). *) -val latex_titles : (int * string) list ref - -(** The prefix to use for value labels in LaTeX. *) -val latex_value_prefix : string ref - -(** The prefix to use for type labels in LaTeX. *) -val latex_type_prefix : string ref - -(** The prefix to use for exception labels in LaTeX. *) -val latex_exception_prefix : string ref - -(** The prefix to use for module labels in LaTeX. *) -val latex_module_prefix : string ref - -(** The prefix to use for module type labels in LaTeX. *) -val latex_module_type_prefix : string ref - -(** The prefix to use for class labels in LaTeX. *) -val latex_class_prefix : string ref - -(** The prefix to use for class type labels in LaTeX. *) -val latex_class_type_prefix : string ref - -(** The prefix to use for attribute labels in LaTeX. *) -val latex_attribute_prefix : string ref - -(** The prefix to use for method labels in LaTeX. *) -val latex_method_prefix : string ref - -(** The flag which indicates if we must generate a table of contents (for LaTeX). *) -val with_toc : bool ref - -(** The flag which indicates if we must generate an index (for TeXinfo). *) -val with_index : bool ref - -(** The flag which indicates if we must escape accentuated characters (for TeXinfo).*) -val esc_8bits : bool ref - -(** The Info directory section *) -val info_section : string ref - -(** The Info directory entries to insert *) -val info_entry : string list ref - -(** Include all modules or only the ones on the command line, for the dot output. *) -val dot_include_all : bool ref - -(** Generate dependency graph for types. *) -val dot_types : bool ref - -(** Perform transitive reduction before dot output. *) -val dot_reduce : bool ref +(** To set the documentation generator. *) +val set_generator : Odoc_gen.generator -> unit -(** The colors used in the dot output. *) -val dot_colors : string list ref +(** Extend current HTML generator. + @raise Failure if another kind of generator is already set.*) +val extend_html_generator : (module Odoc_gen.Html_functor) -> unit -(** The suffix for man pages. *) -val man_suffix : string ref +(** Extend current LaTeX generator. + @raise Failure if another kind of generator is already set.*) +val extend_latex_generator : (module Odoc_gen.Latex_functor) -> unit -(** The section for man pages. *) -val man_section : string ref +(** Extend current Texi generator. + @raise Failure if another kind of generator is already set.*) +val extend_texi_generator : (module Odoc_gen.Texi_functor) -> unit -(** The flag to generate all man pages or only for modules and classes.*) -val man_mini : bool ref +(** Extend current man generator. + @raise Failure if another kind of generator is already set.*) +val extend_man_generator : (module Odoc_gen.Man_functor) -> unit -(** The files to be analysed. *) -val files : source_file list ref +(** Extend current dot generator. + @raise Failure if another kind of generator is already set.*) +val extend_dot_generator : (module Odoc_gen.Dot_functor) -> unit -(** To set the documentation generator. *) -val set_doc_generator : doc_generator option -> unit +(** Extend current base generator. + @raise Failure if another kind of generator is already set.*) +val extend_base_generator : (module Odoc_gen.Base_functor) -> unit (** Add an option specification. *) val add_option : string * Arg.spec * string -> unit (** Parse the args. [byte] indicate if we are in bytecode mode (default is [true]).*) -val parse : - html_generator:doc_generator -> - latex_generator:doc_generator -> - texi_generator:doc_generator -> - man_generator:doc_generator -> - dot_generator:doc_generator -> - unit +val parse : unit -> unit diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 3456e14d..79db5e95 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -357,6 +357,13 @@ module Analyser = let name_pre = Name.from_ident ident in let name = Name.parens_if_infix name_pre in let complete_name = Name.concat current_module_name name in + let code = + if !Odoc_global.keep_code then + Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum + loc.Location.loc_end.Lexing.pos_cnum) + else + None + in (* create the value *) let new_value = { val_name = complete_name ; @@ -364,7 +371,7 @@ module Analyser = val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ; val_recursive = rec_flag = Asttypes.Recursive ; val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ; - val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_code = code ; val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; } in @@ -375,13 +382,20 @@ module Analyser = let name_pre = Name.from_ident ident in let name = Name.parens_if_infix name_pre in let complete_name = Name.concat current_module_name name in + let code = + if !Odoc_global.keep_code then + Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum + loc.Location.loc_end.Lexing.pos_cnum) + else + None + in let new_value = { val_name = complete_name ; val_info = comment_opt ; val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ; val_recursive = rec_flag = Asttypes.Recursive ; val_parameters = [] ; - val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; + val_code = code ; val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; } in @@ -437,7 +451,7 @@ module Analyser = | l -> match l with [] -> - (* cas impossible, on l'a filtré avant *) + (* cas impossible, on l'a filtré avant *) assert false | (pattern_param, exp) :: second_ele :: q -> (* implicit pattern matching -> anonymous parameter *) @@ -543,111 +557,129 @@ module Analyser = | ((Parsetree.Pcf_val (label, mutable_flag, _, _, loc) | Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) as x) :: q -> - 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 = + 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 if virt then Typedtree_search.search_virtual_attribute_type table - (Name.simple current_class_name) label + (Name.simple current_class_name) label else Typedtree_search.search_attribute_type tt_cls label with Not_found -> raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name)) - in - let att = - { - att_value = { val_name = complete_name ; - val_info = info_opt ; - val_type = Odoc_env.subst_type env type_exp ; - val_recursive = false ; - val_parameters = [] ; - val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; - val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; - } ; - att_mutable = mutable_flag = Asttypes.Mutable ; - att_virtual = virt ; - } - in - iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q + in + let code = + if !Odoc_global.keep_code then + Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum + loc.Location.loc_end.Lexing.pos_cnum) + else + None + in + let att = + { + att_value = { val_name = complete_name ; + val_info = info_opt ; + val_type = Odoc_env.subst_type env type_exp ; + val_recursive = false ; + val_parameters = [] ; + val_code = code ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } ; + att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virt ; + } + in + iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q | (Parsetree.Pcf_virt (label, private_flag, _, loc)) :: q -> - 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 - | _ -> + Tarrow (_, _, t, _) -> + t + | _ -> (* ?!? : not an arrow type ! return the original type *) - met_type - in - let met = - { - met_value = { val_name = complete_name ; - val_info = info_opt ; - val_type = Odoc_env.subst_type env real_type ; - val_recursive = false ; - val_parameters = [] ; - val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; - val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; - } ; - met_private = private_flag = Asttypes.Private ; - met_virtual = true ; - } - in - (* update the parameter description *) - Odoc_value.update_value_parameters_text met.met_value; + met_type + in + let code = + if !Odoc_global.keep_code then + Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum + loc.Location.loc_end.Lexing.pos_cnum) + else + None + in + let met = + { + met_value = { + val_name = complete_name ; + val_info = info_opt ; + val_type = Odoc_env.subst_type env real_type ; + val_recursive = false ; + val_parameters = [] ; + val_code = code ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } ; + met_private = private_flag = Asttypes.Private ; + met_virtual = true ; + } + in + (* update the parameter description *) + Odoc_value.update_value_parameters_text met.met_value; - iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q + iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q | (Parsetree.Pcf_meth (label, private_flag, _, _, loc)) :: q -> - 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 - let real_type = - match exp.exp_type.desc with - Tarrow (_, _, t,_) -> - t - | _ -> + with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name)) + in + let real_type = + match exp.exp_type.desc with + Tarrow (_, _, t,_) -> + t + | _ -> (* ?!? : not an arrow type ! return the original type *) - exp.Typedtree.exp_type - in - let met = - { - met_value = { val_name = complete_name ; - val_info = info_opt ; - val_type = Odoc_env.subst_type env real_type ; - val_recursive = false ; - val_parameters = tt_analyse_method_expression env complete_name info_opt exp ; - val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; - val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; - } ; - met_private = private_flag = Asttypes.Private ; - met_virtual = false ; + exp.Typedtree.exp_type + in + let code = + if !Odoc_global.keep_code then + Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum + loc.Location.loc_end.Lexing.pos_cnum) + else + None + in + let met = + { + met_value = { val_name = complete_name ; + val_info = info_opt ; + val_type = Odoc_env.subst_type env real_type ; + val_recursive = false ; + val_parameters = tt_analyse_method_expression env complete_name info_opt exp ; + val_code = code ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } ; + met_private = private_flag = Asttypes.Private ; + met_virtual = false ; } - in - (* update the parameter description *) - Odoc_value.update_value_parameters_text met.met_value; + in + (* update the parameter description *) + Odoc_value.update_value_parameters_text met.met_value; - iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q + iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q | Parsetree.Pcf_cstr (_, _, loc) :: q -> (* don't give a $*%@ ! *) iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q - | Parsetree.Pcf_let (_, _, loc) :: q -> - (* don't give a $*%@ ! *) - iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q - | (Parsetree.Pcf_init exp) :: q -> iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q in @@ -662,10 +694,10 @@ module Analyser = Typedtree.Tclass_ident p -> Name.from_path p | _ -> (* we try to get the name from the environment. *) - (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) + (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) Name.from_longident lid in - (* On n'a pas ici les paramètres de type sous forme de Types.type_expr, + (* On n'a pas ici les paramètres de type sous forme de Types.type_expr, par contre on peut les trouver dans le class_type *) let params = match tt_class_exp.Typedtree.cl_type with @@ -750,7 +782,7 @@ module Analyser = match tt_class_expr2.Typedtree.cl_desc with Typedtree.Tclass_ident p -> Name.from_path p (* A VOIR : obtenir le nom complet *) | _ -> - (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) + (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) match p_class_expr2.Parsetree.pcl_desc with Parsetree.Pcl_constr (lid, _) -> (* we try to get the name from the environment. *) @@ -942,7 +974,7 @@ module Analyser = | Element_type t -> (function Types.Tsig_type (ident,_,_) -> - (* A VOIR: il est possible que le détail du type soit caché *) + (* A VOIR: il est possible que le détail du type soit caché *) let n1 = Name.simple t.ty_name and n2 = Ident.name ident in n1 = n2 @@ -1090,108 +1122,115 @@ module Analyser = (0, new_env, l_ele) | Parsetree.Pstr_primitive (name_pre, val_desc) -> - (* of string * value_description *) - print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]"); - let typ = Typedtree_search.search_primitive table name_pre in - let name = Name.parens_if_infix name_pre in - let complete_name = Name.concat current_module_name name in - let new_value = { - val_name = complete_name ; - val_info = comment_opt ; - val_type = Odoc_env.subst_type env typ ; - val_recursive = false ; - val_parameters = [] ; - val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ; - val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; - } - in - let new_env = Odoc_env.add_value env new_value.val_name in - (0, new_env, [Element_value new_value]) + (* of string * value_description *) + print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]"); + let typ = Typedtree_search.search_primitive table name_pre in + let name = Name.parens_if_infix name_pre in + let complete_name = Name.concat current_module_name name in + let code = + if !Odoc_global.keep_code then + Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum + loc.Location.loc_end.Lexing.pos_cnum) + else + None + in + let new_value = { + val_name = complete_name ; + val_info = comment_opt ; + val_type = Odoc_env.subst_type env typ ; + val_recursive = false ; + val_parameters = [] ; + val_code = code ; + val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + } + in + 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 (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, []) - | (name, type_decl) :: q -> - let complete_name = Name.concat current_module_name name in - let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in - let loc_end = type_decl.Parsetree.ptype_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, []) + | (name, type_decl) :: q -> + let complete_name = Name.concat current_module_name name in + let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = type_decl.Parsetree.ptype_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 - in - let (maybe_more, name_comment_list) = + [] -> pos_limit + | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum + in + let (maybe_more, name_comment_list) = Sig.name_comment_from_type_kind - loc_end - pos_limit2 - type_decl.Parsetree.ptype_kind - in - let tt_type_decl = - try Typedtree_search.search_type_declaration table name - with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name)) - in - let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) - if first then - (comment_opt , []) - else - get_comments_in_module last_pos loc_start - in - let kind = Sig.get_type_kind + loc_end + pos_limit2 + type_decl.Parsetree.ptype_kind + in + let tt_type_decl = + try Typedtree_search.search_type_declaration table name + with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name)) + in + let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) + if first then + (comment_opt , []) + else + get_comments_in_module last_pos loc_start + in + let kind = Sig.get_type_kind new_env name_comment_list tt_type_decl.Types.type_kind - in - let new_end = loc_end + maybe_more in - let t = - { - ty_name = complete_name ; - ty_info = com_opt ; - ty_parameters = + in + let new_end = loc_end + maybe_more in + let t = + { + ty_name = complete_name ; + ty_info = com_opt ; + ty_parameters = List.map2 - (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) + (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 ; - ty_kind = kind ; - ty_private = tt_type_decl.Types.type_private; - ty_manifest = - (match tt_type_decl.Types.type_manifest with - None -> None - | Some t -> Some (Odoc_env.subst_type new_env t)); - ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ; - ty_code = + ty_kind = kind ; + ty_private = tt_type_decl.Types.type_private; + ty_manifest = + (match tt_type_decl.Types.type_manifest with + None -> None + | Some t -> Some (Odoc_env.subst_type new_env t)); + ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ; + ty_code = ( - if !Odoc_args.keep_code then + if !Odoc_global.keep_code then Some (get_string_of_file loc_start new_end) else None ) ; - } - in - let (maybe_more2, info_after_opt) = - My_ir.just_after_special + } + in + let (maybe_more2, info_after_opt) = + My_ir.just_after_special !file_name (get_string_of_file new_end pos_limit2) - in - t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ; - let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in - (maybe_more3, ele_comments @ ((Element_type t) :: eles)) - in - let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in - (maybe_more, new_env, eles) + in + t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ; + let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in + (maybe_more3, ele_comments @ ((Element_type t) :: eles)) + in + let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in + (maybe_more, new_env, eles) | Parsetree.Pstr_exception (name, excep_decl) -> (* a new exception is defined *) @@ -1209,12 +1248,12 @@ module Analyser = { ex_name = complete_name ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ; + ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl.exn_args ; ex_alias = None ; ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; ex_code = ( - if !Odoc_args.keep_code then + if !Odoc_global.keep_code then Some (get_string_of_file loc_start loc_end) else None @@ -1260,7 +1299,7 @@ module Analyser = tt_module_expr in let code = - if !Odoc_args.keep_code then + if !Odoc_global.keep_code then let loc = module_expr.Parsetree.pmod_loc in let st = loc.Location.loc_start.Lexing.pos_cnum in let en = loc.Location.loc_end.Lexing.pos_cnum in @@ -1274,7 +1313,7 @@ module Analyser = let new_env = Odoc_env.add_module env new_module.m_name in let new_env2 = match new_module.m_type with - (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s @@ -1373,7 +1412,7 @@ module Analyser = let new_env = Odoc_env.add_module_type env mt.mt_name in let new_env2 = match tt_module_type with - (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *) + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *) Types.Tmty_signature s -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s | _ -> @@ -1501,7 +1540,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 : étendre l'environnement ? avec quoi ? *) (** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*) and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr = @@ -1622,7 +1661,7 @@ module Analyser = p_modtype tt_modtype in let tt_modtype = Odoc_env.subst_module_type env tt_modtype in - if !Odoc_args.filter_with_module_constraints then + if !Odoc_global.filter_with_module_constraints then filter_module_with_module_type_constraint m_base2 tt_modtype; { m_base with @@ -1647,7 +1686,7 @@ module Analyser = m_kind = Module_struct elements2 ; } - | (Parsetree.Pmod_unpack (p_exp, pkg_type), + | (Parsetree.Pmod_unpack (p_exp), Typedtree.Tmod_unpack (t_exp, tt_modtype)) -> print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name); let code = @@ -1658,7 +1697,13 @@ module Analyser = let s = get_string_of_file exp_loc_end loc_end in Printf.sprintf "(val ...%s" s in - let name = Odoc_env.full_module_type_name env (Name.from_longident (fst pkg_type)) in + (* let name = Odoc_env.full_module_type_name env (Name.from_path (fst pkg_type)) in *) + let name = + match tt_modtype with + | Tmty_ident p -> + Odoc_env.full_module_type_name env (Name.from_path p) + | _ -> "" + in let alias = { mta_name = name ; mta_module = None } in { m_base with m_type = Odoc_env.subst_module_type env tt_modtype ; @@ -1725,7 +1770,7 @@ module Analyser = m_kind = kind ; m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; m_top_deps = [] ; - m_code = (if !Odoc_args.keep_code then Some !file else None) ; + m_code = (if !Odoc_global.keep_code then Some !file else None) ; m_code_intf = None ; m_text_only = false ; } diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml index 676d0ebc..28abf670 100644 --- a/ocamldoc/odoc_class.ml +++ b/ocamldoc/odoc_class.ml @@ -115,7 +115,7 @@ let rec class_elements ?(trans=true) cl = | Class_constraint (c_kind, ct_kind) -> iter_kind c_kind (* A VOIR : utiliser le c_kind ou le ct_kind ? - Pour l'instant, comme le ct_kind n'est pas analysé, + Pour l'instant, comme le ct_kind n'est pas analysé, on cherche dans le c_kind class_type_elements ~trans: trans { clt_name = "" ; clt_info = None ; diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index ea5427e0..af524eef 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -38,7 +38,7 @@ module Info_retriever = | Odoc_text.Text_syntax (l, c, s) -> raise (Failure (Odoc_messages.text_parse_error l c s)) | _ -> - raise (Failure ("Erreur inconnue lors du parse de see : "^s)) + raise (Failure ("Unknown error while parsing @see tag: "^s)) let retrieve_info fun_lex file (s : string) = try diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index 962da359..cd79790d 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -58,7 +58,9 @@ module P_alias = let p_class c _ = (false, false) let p_class_type ct _ = (false, false) let p_value v _ = false - let p_type t _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type t _ = (false, false) let p_exception e _ = e.ex_alias <> None let p_attribute a _ = false let p_method m _ = false @@ -178,7 +180,7 @@ let kind_name_exists kind = match kind with RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false) | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false) - | RK_class -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) + | RK_class -> (fun e -> match e with Odoc_search.Res_class _ -> true | _ -> false) | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) @@ -186,6 +188,8 @@ let kind_name_exists kind = | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) | RK_section _ -> assert false + | RK_recfield -> (fun e -> match e with Odoc_search.Res_recfield _ -> true | _ -> false) + | RK_const -> (fun e -> match e with Odoc_search.Res_const _ -> true | _ -> false) in fun name -> try List.exists pred (get_known_elements name) @@ -200,6 +204,8 @@ let type_exists = kind_name_exists RK_type let exception_exists = kind_name_exists RK_exception let attribute_exists = kind_name_exists RK_attribute let method_exists = kind_name_exists RK_method +let recfield_exists = kind_name_exists RK_recfield +let const_exists = kind_name_exists RK_const let lookup_module name = match List.find @@ -246,8 +252,17 @@ class scan = inherit Odoc_scan.scanner method! scan_value v = add_known_element v.val_name (Odoc_search.Res_value v) - method! scan_type t = - add_known_element t.ty_name (Odoc_search.Res_type t) + method! scan_type_recfield t f = + add_known_element + (Printf.sprintf "%s.%s" t.ty_name f.rf_name) + (Odoc_search.Res_recfield (t, f)) + method! scan_type_const t f = + add_known_element + (Printf.sprintf "%s.%s" t.ty_name f.vc_name) + (Odoc_search.Res_const (t, f)) + method! scan_type_pre t = + add_known_element t.ty_name (Odoc_search.Res_type t); + true method! scan_exception e = add_known_element e.ex_name (Odoc_search.Res_exception e) method! scan_attribute a = @@ -620,6 +635,8 @@ let not_found_of_kind kind name = | RK_attribute -> Odoc_messages.cross_attribute_not_found | RK_method -> Odoc_messages.cross_method_not_found | RK_section _ -> Odoc_messages.cross_section_not_found + | RK_recfield -> Odoc_messages.cross_recfield_not_found + | RK_const -> Odoc_messages.cross_const_not_found ) name let rec assoc_comments_text_elements parent_name module_list t_ele = @@ -675,6 +692,10 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) | Odoc_search.Res_section (_ ,t)-> assert false + | Odoc_search.Res_recfield (t, f) -> + (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield) + | Odoc_search.Res_const (t, f) -> + (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const) in add_verified (name, Some kind) ; (name, Some kind) @@ -684,7 +705,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | (_, None) -> match parent_name with None -> - Odoc_messages.pwarning (Odoc_messages.cross_element_not_found initial_name); + Odoc_global.pwarning (Odoc_messages.cross_element_not_found initial_name); Ref (initial_name, None, text_option) | Some p -> let parent_name = @@ -731,6 +752,8 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | RK_attribute -> attribute_exists | RK_method -> method_exists | RK_section _ -> assert false + | RK_recfield -> recfield_exists + | RK_const -> const_exists in if f name then ( @@ -745,7 +768,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | (_, None) -> match parent_name with None -> - Odoc_messages.pwarning (not_found_of_kind kind initial_name); + Odoc_global.pwarning (not_found_of_kind kind initial_name); Ref (initial_name, None, text_option) | Some p -> let parent_name = @@ -987,7 +1010,7 @@ let associate module_list = | l -> List.iter (fun nf -> - Odoc_messages.pwarning + Odoc_global.pwarning ( match nf with NF_m n -> Odoc_messages.cross_module_not_found n diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index 86a0f247..8878e723 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -1,5 +1,5 @@ (***********************************************************************) -(* OCamldoc *) +(* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml index 452bf2bf..a0d5ee22 100644 --- a/ocamldoc/odoc_dot.ml +++ b/ocamldoc/odoc_dot.ml @@ -1,5 +1,5 @@ (***********************************************************************) -(* Ocamldoc *) +(* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) @@ -18,6 +18,17 @@ open Odoc_info module F = Format +let dot_include_all = ref false + +let dot_types = ref false + +let dot_reduce = ref false + +let dot_colors = ref (List.flatten Odoc_messages.default_dot_colors) + +module Generator = +struct + (** This class generates a dot file showing the top modules dependencies. *) class dot = object (self) @@ -29,7 +40,7 @@ class dot = val mutable modules = [] (** Colors to use when finding new locations of modules. *) - val mutable colors = !Args.dot_colors + val mutable colors = !dot_colors (** Graph header. *) method header = @@ -73,7 +84,7 @@ class dot = method generate_for_module fmt m = let l = List.filter (fun n -> - !Args.dot_include_all or + !dot_include_all or (List.exists (fun m -> m.Module.m_name = n) modules)) m.Module.m_top_deps in @@ -88,11 +99,11 @@ class dot = method generate_types types = try - let oc = open_out !Args.out_file in + let oc = open_out !Global.out_file in let fmt = F.formatter_of_out_channel oc in F.fprintf fmt "%s" self#header; let graph = Odoc_info.Dep.deps_of_types - ~kernel: !Args.dot_reduce + ~kernel: !dot_reduce types in List.iter (self#generate_for_type fmt) graph; @@ -106,11 +117,11 @@ class dot = method generate_modules modules_list = try modules <- modules_list ; - let oc = open_out !Args.out_file in + let oc = open_out !Global.out_file in let fmt = F.formatter_of_out_channel oc in F.fprintf fmt "%s" self#header; - if !Args.dot_reduce then + if !dot_reduce then Odoc_info.Dep.kernel_deps_of_modules modules_list; List.iter (self#generate_for_module fmt) modules_list; @@ -123,9 +134,13 @@ class dot = (** Generate the dot code in the file {!Odoc_info.Args.out_file}. *) method generate (modules_list : Odoc_info.Module.t_module list) = - colors <- !Args.dot_colors; - if !Args.dot_types then + colors <- !dot_colors; + if !dot_types then self#generate_types (Odoc_info.Search.types modules_list) else self#generate_modules modules_list end +end + +module type Dot_generator = module type of Generator + diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index a108cf41..9a1c941d 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -56,7 +56,7 @@ let rec add_signature env root ?rel signat = | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } | Types.Tsig_module (ident, modtype, _) -> let env2 = - match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) + match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s | _ -> env in @@ -68,7 +68,7 @@ let rec add_signature env root ?rel signat = env | Types.Tmodtype_manifest modtype -> match modtype with - (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) + (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s | _ -> env in diff --git a/ocamldoc/odoc_gen.ml b/ocamldoc/odoc_gen.ml new file mode 100644 index 00000000..b1909e78 --- /dev/null +++ b/ocamldoc/odoc_gen.ml @@ -0,0 +1,60 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, 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. *) +(* *) +(***********************************************************************) + +(** *) + +class type doc_generator = + object method generate : Odoc_module.t_module list -> unit end;; + +module type Base = sig + class generator : doc_generator + end;; + +module Base_generator : Base = struct + class generator : doc_generator = object method generate l = () end + end;; + +module type Base_functor = functor (G: Base) -> Base +module type Html_functor = functor (G: Odoc_html.Html_generator) -> Odoc_html.Html_generator +module type Latex_functor = functor (G: Odoc_latex.Latex_generator) -> Odoc_latex.Latex_generator +module type Texi_functor = functor (G: Odoc_texi.Texi_generator) -> Odoc_texi.Texi_generator +module type Man_functor = functor (G: Odoc_man.Man_generator) -> Odoc_man.Man_generator +module type Dot_functor = functor (G: Odoc_dot.Dot_generator) -> Odoc_dot.Dot_generator + +type generator = + | Html of (module Odoc_html.Html_generator) + | Latex of (module Odoc_latex.Latex_generator) + | Texi of (module Odoc_texi.Texi_generator) + | Man of (module Odoc_man.Man_generator) + | Dot of (module Odoc_dot.Dot_generator) + | Base of (module Base) +;; + +let get_minimal_generator = function + Html m -> + let module M = (val m : Odoc_html.Html_generator) in + (new M.html :> doc_generator) +| Latex m -> + let module M = (val m : Odoc_latex.Latex_generator) in + (new M.latex :> doc_generator) +| Man m -> + let module M = (val m : Odoc_man.Man_generator) in + (new M.man :> doc_generator) +| Texi m -> + let module M = (val m : Odoc_texi.Texi_generator) in + (new M.texi :> doc_generator) +| Dot m -> + let module M = (val m : Odoc_dot.Dot_generator) in + (new M.dot :> doc_generator) +| Base m -> + let module M = (val m : Base) in + new M.generator + ;; diff --git a/ocamldoc/odoc_gen.mli b/ocamldoc/odoc_gen.mli new file mode 100644 index 00000000..37768c00 --- /dev/null +++ b/ocamldoc/odoc_gen.mli @@ -0,0 +1,42 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, 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. *) +(* *) +(***********************************************************************) + +(** The types of generators. *) + +(** The minimal class type of documentation generators. *) +class type doc_generator = + object method generate : Odoc_module.t_module list -> unit end;; + +(** The module type of minimal generators. *) +module type Base = sig + class generator : doc_generator + end;; + +module Base_generator : Base + +module type Base_functor = functor (P: Base) -> Base +module type Html_functor = functor (G: Odoc_html.Html_generator) -> Odoc_html.Html_generator +module type Latex_functor = functor (G: Odoc_latex.Latex_generator) -> Odoc_latex.Latex_generator +module type Texi_functor = functor (G: Odoc_texi.Texi_generator) -> Odoc_texi.Texi_generator +module type Man_functor = functor (G: Odoc_man.Man_generator) -> Odoc_man.Man_generator +module type Dot_functor = functor (G: Odoc_dot.Dot_generator) -> Odoc_dot.Dot_generator + +(** Various ways to create a generator. *) +type generator = + | Html of (module Odoc_html.Html_generator) + | Latex of (module Odoc_latex.Latex_generator) + | Texi of (module Odoc_texi.Texi_generator) + | Man of (module Odoc_man.Man_generator) + | Dot of (module Odoc_dot.Dot_generator) + | Base of (module Base) +;; + +val get_minimal_generator : generator -> doc_generator diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml index 4e084566..b2d7bf87 100644 --- a/ocamldoc/odoc_global.ml +++ b/ocamldoc/odoc_global.ml @@ -1,5 +1,5 @@ (***********************************************************************) -(* OCamldoc *) +(* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) @@ -13,10 +13,77 @@ (** Global variables. *) +(* Tell ocaml compiler not to generate files. *) +let _ = Clflags.dont_write_files := true + +open Clflags + +type source_file = + Impl_file of string + | Intf_file of string + | Text_file of string + +let include_dirs = Clflags.include_dirs + let errors = ref 0 let warn_error = ref false +let pwarning s = + if !Odoc_config.print_warnings then prerr_endline (Odoc_messages.warning^": "^s); + if !warn_error then incr errors + +let merge_options = ref ([] : Odoc_types.merge_option list) + +let classic = Clflags.classic + +let dump = ref (None : string option) + +let load = ref ([] : string list) + +(** Allow arbitrary recursive types. *) +let recursive_types = Clflags.recursive_types + +(** Optional preprocessor command. *) +let preprocessor = Clflags.preprocessor + +let sort_modules = ref false + +let no_custom_tags = ref false + +let no_stop = ref false + +let remove_stars = ref false + +let keep_code = ref false + +let inverse_merge_ml_mli = ref false + +let filter_with_module_constraints = ref true + +let hidden_modules = ref ([] : string list) + +let files = ref [] + + + +let out_file = ref Odoc_messages.default_out_file + +let verbose = ref false + +let target_dir = ref Filename.current_dir_name + +let title = ref (None : string option) + +let intro_file = ref (None : string option) + +let with_header = ref true + +let with_trailer = ref true + +let with_toc = ref true + +let with_index = ref true + + -(* Tell ocaml compiler not to generate files. *) -let _ = Clflags.dont_write_files := true diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli index 3a9eab65..d3d17ebe 100644 --- a/ocamldoc/odoc_global.mli +++ b/ocamldoc/odoc_global.mli @@ -1,5 +1,5 @@ (***********************************************************************) -(* Ocamldoc *) +(* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) @@ -13,8 +13,92 @@ (** Global variables. *) +(** The kind of source file in arguments. *) +type source_file = + Impl_file of string + | Intf_file of string + | Text_file of string + +(** The include_dirs in the OCaml compiler. *) +val include_dirs : string list ref + +(** Optional preprocessor command to pass to ocaml compiler. *) +val preprocessor : string option ref + +(** Recursive types flag to passe to ocaml compiler. *) +val recursive_types : bool ref + +(** The merge options to be used. *) +val merge_options : Odoc_types.merge_option list ref + +(** Classic mode or not. *) +val classic : bool ref + +(** The optional file name to dump the collected information into.*) +val dump : string option ref + +(** The list of information files to load. *) +val load : string list ref + +(** We must sort the list of top modules or not.*) +val sort_modules : bool ref + +(** We must not stop at the stop special comments. Default is false (we stop).*) +val no_stop : bool ref + +(** We must raise an exception when we find an unknown @-tag. *) +val no_custom_tags : bool ref + +(** We must remove the the first characters of each comment line, until the first asterisk '*'. *) +val remove_stars : bool ref + +(** To keep the code while merging, when we have both .ml and .mli files for a module. *) +val keep_code : bool ref + +(** To inverse implementation and interface files when merging. *) +val inverse_merge_ml_mli : bool ref + +(** To filter module elements according to module type constraints. *) +val filter_with_module_constraints : bool ref + +(** The list of module names to hide. *) +val hidden_modules : string list ref + +(** The files to be analysed. *) +val files : source_file list ref (** A counter for errors. *) val errors : int ref (** Indicate if a warning is an error. *) val warn_error : bool ref + +(** Print the given warning, adding it to the list of {!errors} +if {!warn_error} is [true]. *) +val pwarning : string -> unit + +(** The file used by the generators outputting only one file. *) +val out_file : string ref + +(** Verbose mode or not. *) +val verbose : bool ref + +(** The optional file whose content can be used as intro text. *) +val intro_file : string option ref + +(** The optional title to use in the generated documentation. *) +val title : string option ref + +(** The directory where files have to be generated. *) +val target_dir : string ref + +(** The flag which indicates if we must generate a table of contents. *) +val with_toc : bool ref + +(** The flag which indicates if we must generate an index. *) +val with_index : bool ref + +(** The flag which indicates if we must generate a header.*) +val with_header : bool ref + +(** The flag which indicates if we must generate a trailer.*) +val with_trailer : bool ref diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 4da125c2..6f494284 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -23,6 +23,13 @@ open Exception open Class open Module +let with_parameter_list = ref false +let css_style = ref None +let index_only = ref false +let colorize_code = ref false +let html_short_functors = ref false +let charset = ref "iso-8859-1" + (** The functions used for naming files and html marks.*) module Naming = @@ -30,6 +37,9 @@ module Naming = (** The prefix for types marks. *) let mark_type = "TYPE" + (** The prefix for types elements (record fields or constructors). *) + let mark_type_elt = "TYPEELT" + (** The prefix for functions marks. *) let mark_function = "FUN" @@ -82,9 +92,25 @@ module Naming = (** Return the link target for the given type. *) let type_target t = target mark_type (Name.simple t.ty_name) + (** Return the link target for the given variant constructor. *) + let const_target t f = + let name = Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.vc_name in + target mark_type_elt name + + (** Return the link target for the given record field. *) + let recfield_target t f = target mark_type_elt + (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.rf_name) + (** Return the complete link target for the given type. *) let complete_type_target t = complete_target mark_type t.ty_name + let complete_recfield_target name = + let typ = Name.father name in + let field = Name.simple name in + Printf.sprintf "%s.%s" (complete_target mark_type_elt typ) field + + let complete_const_target = complete_recfield_target + (** Return the link target for the given exception. *) let exception_target e = target mark_exception (Name.simple e.ex_name) @@ -270,7 +296,7 @@ class virtual text = method html_of_Raw b s = bs b (self#escape s) method html_of_Code b s = - if !Args.colorize_code then + if !colorize_code then self#html_of_code b ~with_pre: false s else ( @@ -308,7 +334,7 @@ class virtual text = | Some last -> String.sub s first ((last-first)+1) in fun b s -> - if !Args.colorize_code then + if !colorize_code then ( bs b "
";
          self#html_of_code b (remove_useless_newlines s);
@@ -433,6 +459,8 @@ class virtual text =
             | Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name)
             | Odoc_info.RK_section t -> (Naming.complete_label_target name,
                                          Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
+            | Odoc_info.RK_recfield -> (Naming.complete_recfield_target name, h name)
+            | Odoc_info.RK_const -> (Naming.complete_const_target name, h name)
           in
           let text =
             match text_opt with
@@ -471,7 +499,7 @@ class virtual text =
              self#html_of_info_first_sentence b m.m_info;
            with
              Not_found ->
-               Odoc_messages.pwarning (Odoc_messages.cross_module_not_found name);
+               Odoc_global.pwarning (Odoc_messages.cross_module_not_found name);
                bp b "%s" name
           );
           bs b "\n"
@@ -724,6 +752,8 @@ let newline_to_indented_br s =
   done;
   Buffer.contents b
 
+module Generator =
+  struct
 (** This class is used to create objects which can generate a simple html documentation. *)
 class html =
   object (self)
@@ -735,7 +765,7 @@ class html =
     method character_encoding () =
       Printf.sprintf
         "\n"
-        !Odoc_info.Args.charset
+        !charset
 
     (** The default style options. *)
     val mutable default_style_options =
@@ -832,10 +862,10 @@ class html =
     val mutable known_modules_names = StringSet.empty
 
     method index_prefix =
-      if !Odoc_args.out_file = Odoc_messages.default_out_file then
+      if !Odoc_global.out_file = Odoc_messages.default_out_file then
         "index"
       else
-        Filename.basename !Odoc_args.out_file
+        Filename.basename !Odoc_global.out_file
 
     (** The main file. *)
     method index =
@@ -895,12 +925,12 @@ class html =
 
     (** Init the style. *)
     method init_style =
-      (match !Args.css_style with
+      (match !css_style with
         None ->
           let default_style = String.concat "\n" default_style_options in
           (
            try
-             let file = Filename.concat !Args.target_dir style_file in
+             let file = Filename.concat !Global.target_dir style_file in
              if Sys.file_exists file then
                Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
              else
@@ -922,7 +952,7 @@ class html =
       style <- "\n"
 
     (** Get the title given by the user *)
-    method title = match !Args.title with None -> "" | Some t -> self#escape t
+    method title = match !Global.title with None -> "" | Some t -> self#escape t
 
     (** Get the title given by the user completed with the given subtitle. *)
     method inner_title s =
@@ -1212,7 +1242,7 @@ class html =
           bs b (self#create_fully_qualified_module_idents_links father a.ma_name);
           bs b ""
       | Module_functor (p, k) ->
-          if !Odoc_info.Args.html_short_functors then
+          if !html_short_functors then
             bs b " "
           else
             bs b "
";
@@ -1220,12 +1250,12 @@ class html =
           (
            match k with
              Module_functor _ -> ()
-           | _ when !Odoc_info.Args.html_short_functors ->
+           | _ when !html_short_functors ->
                bs b ": "
            | _ -> ()
           );
           self#html_of_module_kind b father ?modu k;
-          if not !Odoc_info.Args.html_short_functors then
+          if not !html_short_functors then
             bs b "
"
       | Module_apply (k1, k2) ->
           (* TODO: l'application n'est pas correcte dans un .mli.
@@ -1235,7 +1265,7 @@ class html =
           self#html_of_module_kind b father k2;
           self#html_of_text b [Code ")"]
       | Module_with (k, s) ->
-          (* TODO: à modifier quand Module_with sera plus détaillé *)
+          (* TODO: à modifier quand Module_with sera plus détaillé *)
           self#html_of_module_type_kind b father ?modu k;
           bs b " ";
           bs b (self#create_fully_qualified_module_idents_links father s);
@@ -1262,7 +1292,7 @@ class html =
 
     method html_of_module_parameter b father p =
       let (s_functor,s_arrow) =
-        if !Odoc_info.Args.html_short_functors then
+        if !html_short_functors then
           "", ""
         else
           "functor ", "-> "
@@ -1363,7 +1393,7 @@ class html =
          None -> bs b (self#escape (Name.simple v.val_name))
        | Some c ->
            let file = Naming.file_code_value_complete_target v in
-           self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
+           self#output_code v.val_name (Filename.concat !Global.target_dir file) c;
            bp b "%s" file (self#escape (Name.simple v.val_name))
       );
       bs b "";
@@ -1372,7 +1402,7 @@ class html =
       bs b "";
       self#html_of_info b v.val_info;
       (
-       if !Args.with_parameter_list then
+       if !with_parameter_list then
          self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters
        else
          self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters
@@ -1457,13 +1487,23 @@ class html =
             bs b (self#keyword "|");
             bs b "\n\n";
             bs b "";
-            bs b (self#constructor constr.vc_name);
+            bp b "%s"
+              (Naming.const_target t constr)
+              (self#constructor constr.vc_name);
             (
-             match constr.vc_args with
-               [] -> ()
-             | l ->
+             match constr.vc_args, constr.vc_ret with
+               [], None -> ()
+             | l,None ->
                  bs b (" " ^ (self#keyword "of") ^ " ");
                  self#html_of_type_expr_list ~par: false b father " * " l;
+             | [],Some r ->
+                 bs b (" " ^ (self#keyword ":") ^ " ");
+                 self#html_of_type_expr b father r;
+             | l,Some r ->
+                 bs b (" " ^ (self#keyword ":") ^ " ");
+                 self#html_of_type_expr_list ~par: false b father " * " l;
+		 bs b (" " ^ (self#keyword "->") ^ " ");
+                 self#html_of_type_expr b father r;
             );
             bs b "\n";
             (
@@ -1504,7 +1544,9 @@ class html =
             bs b "\n\n";
             bs b "";
             if r.rf_mutable then bs b (self#keyword "mutable ") ;
-            bs b (r.rf_name ^ " : ") ;
+            bp b "%s :"
+              (Naming.recfield_target t r)
+              r.rf_name;
             self#html_of_type_expr b father r.rf_type;
             bs b ";\n";
             (
@@ -1552,7 +1594,7 @@ class html =
          None -> bs b (Name.simple a.att_value.val_name)
        | Some c ->
            let file = Naming.file_code_attribute_complete_target a in
-           self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
+           self#output_code a.att_value.val_name (Filename.concat !Global.target_dir file) c;
            bp b "%s" file (Name.simple a.att_value.val_name);
       );
       bs b "";
@@ -1575,7 +1617,7 @@ class html =
          None -> bs b  (Name.simple m.met_value.val_name)
        | Some c ->
            let file = Naming.file_code_method_complete_target m in
-           self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
+           self#output_code m.met_value.val_name (Filename.concat !Global.target_dir file) c;
            bp b "%s" file (Name.simple m.met_value.val_name);
       );
       bs b "";
@@ -1584,7 +1626,7 @@ class html =
       bs b "";
       self#html_of_info b m.met_value.val_info;
       (
-       if !Args.with_parameter_list then
+       if !with_parameter_list then
          self#html_of_parameter_list b
            module_name m.met_value.val_parameters
        else
@@ -1718,7 +1760,7 @@ class html =
       );
       (
        match m.m_kind with
-         Module_functor _ when !Odoc_info.Args.html_short_functors  ->
+         Module_functor _ when !html_short_functors  ->
            ()
        | _ -> bs b ": "
       );
@@ -1817,7 +1859,7 @@ class html =
           self#html_of_text b [Code "end"]
 
       | Class_apply capp ->
-          (* TODO: afficher le type final à partir du typedtree *)
+          (* TODO: afficher le type final à partir du typedtree *)
           self#html_of_text b [Raw "class application not handled yet"]
 
       | Class_constr cco ->
@@ -2064,7 +2106,7 @@ class html =
               ('a -> string) -> string -> string -> unit =
     fun elements name info target title simple_file ->
       try
-        let chanout = open_out (Filename.concat !Args.target_dir simple_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir simple_file) in
         let b = new_buf () in
         bs b "\n";
         self#print_header b (self#inner_title title);
@@ -2130,7 +2172,7 @@ class html =
       let (html_file, _) = Naming.html_files cl.cl_name in
       let type_file = Naming.file_type_class_complete_target cl.cl_name in
       try
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun c -> c.cl_name) pre in
         let post_name = opt (fun c -> c.cl_name) post in
@@ -2165,7 +2207,7 @@ class html =
         (* generate the file with the complete class type *)
         self#output_class_type
           cl.cl_name
-          (Filename.concat !Args.target_dir type_file)
+          (Filename.concat !Global.target_dir type_file)
           cl.cl_type
       with
         Sys_error s ->
@@ -2177,7 +2219,7 @@ class html =
       let (html_file, _) = Naming.html_files clt.clt_name in
       let type_file = Naming.file_type_class_complete_target clt.clt_name in
       try
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun ct -> ct.clt_name) pre in
         let post_name = opt (fun ct -> ct.clt_name) post in
@@ -2211,7 +2253,7 @@ class html =
         (* generate the file with the complete class type *)
         self#output_class_type
           clt.clt_name
-          (Filename.concat !Args.target_dir type_file)
+          (Filename.concat !Global.target_dir type_file)
           clt.clt_type
       with
         Sys_error s ->
@@ -2223,7 +2265,7 @@ class html =
       try
         let (html_file, _) = Naming.html_files mt.mt_name in
         let type_file = Naming.file_type_module_complete_target mt.mt_name in
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun mt -> mt.mt_name) pre in
         let post_name = opt (fun mt -> mt.mt_name) post in
@@ -2276,7 +2318,7 @@ class html =
          | Some mty ->
              self#output_module_type
                mt.mt_name
-               (Filename.concat !Args.target_dir type_file)
+               (Filename.concat !Global.target_dir type_file)
                mty
         )
       with
@@ -2291,7 +2333,7 @@ class html =
         let (html_file, _) = Naming.html_files modu.m_name in
         let type_file = Naming.file_type_module_complete_target modu.m_name in
         let code_file = Naming.file_code_module_complete_target modu.m_name in
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun m -> m.m_name) pre in
         let post_name = opt (fun m -> m.m_name) post in
@@ -2355,7 +2397,7 @@ class html =
         (* generate the file with the complete module type *)
         self#output_module_type
           modu.m_name
-          (Filename.concat !Args.target_dir type_file)
+          (Filename.concat !Global.target_dir type_file)
           modu.m_type;
 
         match modu.m_code with
@@ -2363,7 +2405,7 @@ class html =
         | Some code ->
             self#output_code
               modu.m_name
-              (Filename.concat !Args.target_dir code_file)
+              (Filename.concat !Global.target_dir code_file)
               code
       with
         Sys_error s ->
@@ -2373,9 +2415,9 @@ class html =
        @raise Failure if an error occurs.*)
     method generate_index module_list =
       try
-        let chanout = open_out (Filename.concat !Args.target_dir self#index) in
+        let chanout = open_out (Filename.concat !Global.target_dir self#index) in
         let b = new_buf () in
-        let title = match !Args.title with None -> "" | Some t -> self#escape t in
+        let title = match !Global.title with None -> "" | Some t -> self#escape t in
         bs b doctype ;
         bs b "\n";
         self#print_header b self#title;
@@ -2385,7 +2427,7 @@ class html =
         bs b "\n" ;
         let info = Odoc_info.apply_opt
             (Odoc_info.info_of_comment_file module_list)
-            !Odoc_info.Args.intro_file
+            !Odoc_info.Global.intro_file
         in
         (
          match info with
@@ -2545,7 +2587,7 @@ class html =
           known_modules_names
           module_types ;
       (* generate html for each module *)
-      if not !Args.index_only then
+      if not !index_only then
         self#generate_elements self#generate_for_module module_list ;
 
       try
@@ -2572,3 +2614,6 @@ class html =
           Buffer.contents b
         )
   end
+end
+
+module type Html_generator = module type of Generator
diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml
index fa3c585e..4cd4a3e3 100644
--- a/ocamldoc/odoc_info.ml
+++ b/ocamldoc/odoc_info.ml
@@ -24,6 +24,8 @@ type ref_kind = Odoc_types.ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element = Odoc_types.text_element =
   | Raw of string
@@ -104,11 +106,11 @@ let analyse_files
     ?(no_stop=false)
     ?(init=[])
     files =
-  Odoc_args.merge_options := merge_options;
-  Odoc_args.include_dirs := include_dirs;
-  Odoc_args.classic := not labels;
-  Odoc_args.sort_modules := sort_modules;
-  Odoc_args.no_stop := no_stop;
+  Odoc_global.merge_options := merge_options;
+  Odoc_global.include_dirs := include_dirs;
+  Odoc_global.classic := not labels;
+  Odoc_global.sort_modules := sort_modules;
+  Odoc_global.no_stop := no_stop;
   Odoc_analyse.analyse_files ~init: init files
 
 let dump_modules = Odoc_analyse.dump_modules
@@ -168,15 +170,15 @@ let is_optional = Odoc_misc.is_optional
 let label_name = Odoc_misc.label_name
 
 let use_hidden_modules n =
-  Odoc_name.hide_given_modules !Odoc_args.hidden_modules n
+  Odoc_name.hide_given_modules !Odoc_global.hidden_modules n
 
 let verbose s =
-  if !Odoc_args.verbose then
+  if !Odoc_global.verbose then
     (print_string s ; print_newline ())
   else
     ()
 
-let warning s = Odoc_messages.pwarning s
+let warning s = Odoc_global.pwarning s
 let print_warnings = Odoc_config.print_warnings
 
 let errors = Odoc_global.errors
@@ -213,12 +215,12 @@ let info_string_of_info i =
    | Some t -> p b "%s" (escape_arobas (text_string_of_text t))
   );
   List.iter
-    (fun s -> p b "\n@author %s" (escape_arobas s))
+    (fun s -> p b "\n@@author %s" (escape_arobas s))
     i.i_authors;
   (
    match i.i_version with
      None -> ()
-   | Some s -> p b "\n@version %s" (escape_arobas s)
+   | Some s -> p b "\n@@version %s" (escape_arobas s)
   );
   (
    (* TODO: escape characters ? *)
@@ -229,7 +231,7 @@ let info_string_of_info i =
    in
    List.iter
      (fun (sref, t) ->
-       p b "\n@see %s %s"
+       p b "\n@@see %s %s"
          (escape_arobas (f_see_ref sref))
          (escape_arobas (text_string_of_text t))
      )
@@ -238,25 +240,25 @@ let info_string_of_info i =
   (
    match i.i_since with
      None -> ()
-   | Some s -> p b "\n@since %s" (escape_arobas s)
+   | Some s -> p b "\n@@since %s" (escape_arobas s)
   );
   (
    match i.i_deprecated with
      None -> ()
    | Some t ->
-       p b "\n@deprecated %s"
+       p b "\n@@deprecated %s"
          (escape_arobas (text_string_of_text t))
   );
   List.iter
     (fun (s, t) ->
-      p b "\n@param %s %s"
+      p b "\n@@param %s %s"
         (escape_arobas s)
         (escape_arobas (text_string_of_text t))
     )
     i.i_params;
   List.iter
     (fun (s, t) ->
-      p b "\n@raise %s %s"
+      p b "\n@@raise %s %s"
         (escape_arobas s)
         (escape_arobas (text_string_of_text t))
     )
@@ -265,12 +267,12 @@ let info_string_of_info i =
    match i.i_return_value with
      None -> ()
    | Some t ->
-       p b "\n@return %s"
+       p b "\n@@return %s"
          (escape_arobas (text_string_of_text t))
   );
   List.iter
     (fun (s, t) ->
-      p b "\n@%s %s" s
+      p b "\n@@%s %s" s
         (escape_arobas (text_string_of_text t))
     )
     i.i_custom;
@@ -293,6 +295,8 @@ module Search =
         | Res_attribute of Value.t_attribute
         | Res_method of Value.t_method
         | Res_section of string * text
+        | Res_recfield of Type.t_type * Type.record_field
+        | Res_const of Type.t_type * Type.variant_constructor
 
     type search_result = result_element list
 
@@ -320,4 +324,4 @@ module Dep =
     let deps_of_types = Odoc_dep.deps_of_types
   end
 
-module Args = Odoc_args
+module Global = Odoc_global
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index c12e451a..a3fc5975 100644
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -25,6 +25,8 @@ type ref_kind = Odoc_types.ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element = Odoc_types.text_element =
   | Raw of string (** Raw text. *)
@@ -201,6 +203,7 @@ module Type :
         {
           vc_name : string ; (** Name of the constructor. *)
           vc_args : Types.type_expr list ; (** Arguments of the constructor. *)
+	  vc_ret : Types.type_expr option ;
           mutable vc_text : text option ; (** Optional description in the associated comment. *)
         }
 
@@ -791,6 +794,8 @@ module Search :
         | Res_attribute of Value.t_attribute
         | Res_method of Value.t_method
         | Res_section of string  * text
+        | Res_recfield of Type.t_type * Type.record_field
+        | Res_const of Type.t_type * Type.variant_constructor
 
       (** The type representing a research result.*)
       type search_result = result_element list
@@ -835,6 +840,10 @@ module Scan :
       (** Scan of 'leaf elements'. *)
 
         method scan_value : Value.t_value -> unit
+
+        method scan_type_pre : Type.t_type -> bool
+        method scan_type_const : Type.t_type -> Type.variant_constructor -> unit
+        method scan_type_recfield : Type.t_type -> Type.record_field -> unit
         method scan_type : Type.t_type -> unit
         method scan_exception : Exception.t_exception -> unit
         method scan_attribute : Value.t_attribute -> unit
@@ -931,152 +940,40 @@ module Dep :
     val deps_of_types : ?kernel: bool -> Type.t_type list -> (Type.t_type * (Name.t list)) list
   end
 
-(** {2 Command line arguments} *)
-
-(**  You can use this module to create custom generators.*)
-module Args :
-    sig
-      (** The kind of source file in arguments. *)
-      type source_file =
-          Impl_file of string
-        | Intf_file of string
-        | Text_file of string
-
-      (** The class type of documentation generators. *)
-      class type doc_generator =
-        object method generate : Module.t_module list -> unit end
-
-      (** The file used by the generators outputting only one file. *)
-      val out_file : string ref
-
-      (** Verbose mode or not. *)
-      val verbose : bool ref
-
-      (** The optional title to use in the generated documentation. *)
-      val title : string option ref
-
-      (** To inverse [.ml] and [.mli] files while merging comments. *)
-      val inverse_merge_ml_mli : bool ref
-
-      (** To filter module elements according to module type constraints. *)
-      val filter_with_module_constraints : bool ref
-
-      (** To keep the code while merging, when we have both .ml and .mli files for a module. *)
-      val keep_code : bool ref
-
-      (** The optional file whose content can be used as intro text. *)
-      val intro_file : string option ref
-
-      (** Flag to indicate whether we must display the complete list of parameters
-         for functions and methods. *)
-      val with_parameter_list : bool ref
-
-      (** The list of module names to hide. *)
-      val hidden_modules : string list ref
-
-      (** The directory where files have to be generated. *)
-      val target_dir : string ref
-
-      (** An optional file to use where a CSS style is defined (for HTML). *)
-      val css_style : string option ref
-
-      (** Generate only index files. (for HTML). *)
-      val index_only : bool ref
-
-      (** To colorize code in HTML generated documentation pages, not code pages. *)
-      val colorize_code : bool ref
-
-      (** To display functors in short form rather than with "functor ... -> ",
-         in HTML generated documentation. *)
-      val html_short_functors : bool ref
-
-      (** Character encoding used in HTML pages header. *)
-      val charset : string ref
-
-      (** The flag which indicates if we must generate a header (for LaTeX). *)
-      val with_header : bool ref
+(** {2 Some global variables} *)
 
-      (** The flag which indicates if we must generate a trailer (for LaTeX). *)
-      val with_trailer : bool ref
-
-      (** The flag to indicate if we must generate one file per module (for LaTeX). *)
-      val separate_files : bool ref
-
-      (** The list of pairs (title level, sectionning style). *)
-      val latex_titles : (int * string) list ref
-
-      (** The prefix to use for value labels in LaTeX. *)
-      val latex_value_prefix : string ref
-
-      (** The prefix to use for type labels in LaTeX. *)
-      val latex_type_prefix : string ref
-
-      (** The prefix to use for exception labels in LaTeX. *)
-      val latex_exception_prefix : string ref
-
-      (** The prefix to use for module labels in LaTeX. *)
-      val latex_module_prefix : string ref
-
-      (** The prefix to use for module type labels in LaTeX. *)
-      val latex_module_type_prefix : string ref
-
-      (** The prefix to use for class labels in LaTeX. *)
-      val latex_class_prefix : string ref
-
-      (** The prefix to use for class type labels in LaTeX. *)
-      val latex_class_type_prefix : string ref
-
-      (** The prefix to use for attribute labels in LaTeX. *)
-      val latex_attribute_prefix : string ref
-
-      (** The prefix to use for method labels in LaTeX. *)
-      val latex_method_prefix : string ref
-
-      (** The flag which indicates if we must generate a table of contents (for LaTeX). *)
-      val with_toc : bool ref
-
-      (** The flag which indicates if we must generate an index (for TeXinfo). *)
-      val with_index : bool ref
-
-      (** The flag which indicates if we must escape accentuated characters (for TeXinfo).*)
-      val esc_8bits : bool ref
-
-      (** The Info directory section *)
-      val info_section : string ref
-
-      (** The Info directory entries to insert *)
-      val info_entry : string list ref
-
-      (** Include all modules or only the ones on the command line, for the dot output. *)
-      val dot_include_all : bool ref
+module Global :
+  sig
+    val errors : int ref
+    val warn_error : bool ref
 
-      (** Generate dependency graph for types. *)
-      val dot_types : bool ref
+    (** The file used by the generators outputting only one file. *)
+    val out_file : string ref
 
-      (** Perform transitive reduction before dot output. *)
-      val dot_reduce : bool ref
+    (** Verbose mode or not. *)
+    val verbose : bool ref
 
-      (** The colors used in the dot output. *)
-      val dot_colors : string list ref
+    (** The directory where files have to be generated. *)
+    val target_dir : string ref
 
-      (** The suffix for man pages. *)
-      val man_suffix : string ref
+    (** The optional title to use in the generated documentation. *)
+    val title : string option ref
 
-      (** The section for man pages. *)
-      val man_section : string ref
+    (** The optional file whose content can be used as intro text. *)
+    val intro_file : string option ref
 
-      (** The flag to generate all man pages or only for modules and classes.*)
-      val man_mini : bool ref
+    (** The flag which indicates if we must generate a table of contents. *)
+    val with_toc : bool ref
 
-      (** The files to be analysed. *)
-      val files : source_file list ref
+    (** The flag which indicates if we must generate an index. *)
+    val with_index : bool ref
 
-      (** To set the documentation generator. *)
-      val set_doc_generator : doc_generator option -> unit
+    (** The flag which indicates if we must generate a header.*)
+    val with_header : bool ref
 
-      (** Add an option specification. *)
-      val add_option : string * Arg.spec * string -> unit
-    end
+    (** The flag which indicates if we must generate a trailer.*)
+    val with_trailer : bool ref
+end
 
 (** Analysis of the given source files.
    @param init is the list of modules already known from a previous analysis.
@@ -1088,7 +985,7 @@ val analyse_files :
           ?sort_modules:bool ->
             ?no_stop:bool ->
               ?init: Odoc_module.t_module list ->
-                Args.source_file list ->
+                Odoc_global.source_file list ->
                   Module.t_module list
 
 (** Dump of a list of modules into a file.
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index 3750996a..f2bff217 100644
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -23,6 +23,29 @@ open Exception
 open Class
 open Module
 
+
+
+let separate_files = ref false
+
+let latex_titles = ref [
+  1, "section" ;
+  2, "subsection" ;
+  3, "subsubsection" ;
+  4, "paragraph" ;
+  5, "subparagraph" ;
+]
+
+let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix
+let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix
+let latex_type_elt_prefix = ref Odoc_messages.default_latex_type_elt_prefix
+let latex_exception_prefix = ref Odoc_messages.default_latex_exception_prefix
+let latex_module_prefix = ref Odoc_messages.default_latex_module_prefix
+let latex_module_type_prefix = ref Odoc_messages.default_latex_module_type_prefix
+let latex_class_prefix = ref Odoc_messages.default_latex_class_prefix
+let latex_class_type_prefix = ref Odoc_messages.default_latex_class_type_prefix
+let latex_attribute_prefix = ref Odoc_messages.default_latex_attribute_prefix
+let latex_method_prefix = ref Odoc_messages.default_latex_method_prefix
+
 let new_buf () = Buffer.create 1024
 let new_fmt () =
   let b = new_buf () in
@@ -60,81 +83,91 @@ class text =
        and with the given latex code. *)
     method section_style level s =
       try
-        let sec = List.assoc level !Args.latex_titles in
+        let sec = List.assoc level !latex_titles in
         "\\"^sec^"{"^s^"}\n"
       with Not_found -> s
 
-    (** Associations of strings to subsitute in latex code. *)
-    val mutable subst_strings = [
-      ("MAXENCE"^"ZZZ", "\\$");
-      ("MAXENCE"^"YYY", "\\&");
-      ("MAXENCE"^"XXX", "{\\textbackslash}") ;
-      ("à", "\\`a") ;
-      ("â", "\\^a") ;
-      ("é", "\\'e") ;
-      ("è", "\\`e") ;
-      ("ê", "\\^e") ;
-      ("ë", "\\\"e") ;
-      ("ç", "\\c{c}") ;
-      ("ô", "\\^o") ;
-      ("ö", "\\\"o") ;
-      ("î", "\\^i") ;
-      ("ï", "\\\"i") ;
-      ("ù", "\\`u") ;
-      ("û", "\\^u") ;
-      ("%", "\\%") ;
-      ("_", "\\_");
-      ("\\.\\.\\.", "$\\ldots$");
-      ("~", "\\~{}");
-      ("#", "\\verb`#`");
-      ("}", "\\}");
-      ("{", "\\{");
-      ("&", "\\&");
-      (">", "$>$");
-      ("<", "$<$");
-      ("=", "$=$");
-      (">=", "$\\geq$");
-      ("<=", "$\\leq$");
-      ("->", "$\\rightarrow$") ;
-      ("<-", "$\\leftarrow$");
-      ("|", "\\textbar ");
-      ("\\^", "\\textasciicircum ") ;
-      ("\\.\\.\\.", "$\\ldots$");
-      ("\\\\", "MAXENCE"^"XXX") ;
-      ("&", "MAXENCE"^"YYY") ;
-      ("\\$", "MAXENCE"^"ZZZ");
-    ]
-
-    val mutable subst_strings_simple =
+    (** Associations of strings to substitute in latex code. *)
+    val subst_strings = List.map (fun (x, y) -> (Str.regexp x, y))
       [
-        ("MAXENCE"^"XXX", "{\\textbackslash}") ;
-        "}", "\\}" ;
-        "{", "\\{" ;
-        ("\\\\", "MAXENCE"^"XXX") ;
+        "\001", "\001\002";
+        "\\\\", "\001b";
+
+        "{", "\\\\{";
+        "}", "\\\\}";
+        "\\$", "\\\\$";
+        "\\^", "{\\\\textasciicircum}";
+        "à", "\\\\`a";
+        "â", "\\\\^a";
+        "é", "\\\\'e";
+        "è", "\\\\`e";
+        "ê", "\\\\^e";
+        "ë", "\\\\\"e";
+        "ç", "\\\\c{c}";
+        "ô", "\\\\^o";
+        "ö", "\\\\\"o";
+        "î", "\\\\^i";
+        "ï", "\\\\\"i";
+        "ù", "\\\\`u";
+        "û", "\\\\^u";
+        "%", "\\\\%";
+        "_", "\\\\_";
+        "~", "\\\\~{}";
+        "#", "{\\char35}";
+        "->", "$\\\\rightarrow$";
+        "<-", "$\\\\leftarrow$";
+        ">=", "$\\\\geq$";
+        "<=", "$\\\\leq$";
+        ">", "$>$";
+        "<", "$<$";
+        "=", "$=$";
+        "|", "{\\\\textbar}";
+        "\\.\\.\\.", "$\\\\ldots$";
+        "&", "\\\\&";
+
+        "\001b", "{\\\\char92}";
+        "\001\002", "\001";
       ]
 
-    val mutable subst_strings_code = [
-      ("MAXENCE"^"ZZZ", "\\$");
-      ("MAXENCE"^"YYY", "\\&");
-      ("MAXENCE"^"XXX", "{\\textbackslash}") ;
-      ("%", "\\%") ;
-      ("_", "\\_");
-      ("~", "\\~{}");
-      ("#", "\\verb`#`");
-      ("}", "\\}");
-      ("{", "\\{");
-      ("&", "\\&");
-      ("\\^", "\\textasciicircum ") ;
-      ("&", "MAXENCE"^"YYY") ;
-      ("\\$", "MAXENCE"^"ZZZ") ;
-      ("\\\\", "MAXENCE"^"XXX") ;
-     ]
+    val subst_strings_simple = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+        "{", "\001l";
+
+        "}", "{\\\\char125}";
+        "'", "{\\\\textquotesingle}";
+        "`", "{\\\\textasciigrave}";
+
+        "\001b", "{\\\\char92}";
+        "\001l", "{\\\\char123}";
+        "\001\002", "\001";
+      ]
+
+    val subst_strings_code = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+        "{", "\001l";
+
+        "}", "{\\\\char125}";
+        "'", "{\\\\textquotesingle}";
+        "`", "{\\\\textasciigrave}";
+        "%", "\\\\%";
+        "_", "\\\\_";
+        "~", "{\\\\char126}";
+        "#", "{\\\\char35}";
+        "&", "\\\\&";
+        "\\$", "\\\\$";
+        "\\^", "{\\\\char94}";
+
+        "\001b", "{\\\\char92}";
+        "\001l", "{\\\\char123}";
+        "\001\002", "\001";
+      ]
 
     method subst l s =
-      List.fold_right
-        (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp s) s2 acc)
-        l
-        s
+      List.fold_left (fun acc (re, st) -> Str.global_replace re st acc) s l
 
     (** Escape the strings which would clash with LaTeX syntax. *)
     method escape s = self#subst subst_strings s
@@ -182,31 +215,37 @@ class text =
       Buffer.contents buf
 
     (** Make a correct label from a value name. *)
-    method value_label ?no_ name = !Args.latex_value_prefix^(self#label ?no_ name)
+    method value_label ?no_ name = !latex_value_prefix^(self#label ?no_ name)
 
     (** Make a correct label from an attribute name. *)
-    method attribute_label ?no_ name = !Args.latex_attribute_prefix^(self#label ?no_ name)
+    method attribute_label ?no_ name = !latex_attribute_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a method name. *)
-    method method_label ?no_ name = !Args.latex_method_prefix^(self#label ?no_ name)
+    method method_label ?no_ name = !latex_method_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a class name. *)
-    method class_label ?no_ name = !Args.latex_class_prefix^(self#label ?no_ name)
+    method class_label ?no_ name = !latex_class_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a class type name. *)
-    method class_type_label ?no_ name = !Args.latex_class_type_prefix^(self#label ?no_ name)
+    method class_type_label ?no_ name = !latex_class_type_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a module name. *)
-    method module_label ?no_ name = !Args.latex_module_prefix^(self#label ?no_ name)
+    method module_label ?no_ name = !latex_module_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a module type name. *)
-    method module_type_label ?no_ name = !Args.latex_module_type_prefix^(self#label ?no_ name)
+    method module_type_label ?no_ name = !latex_module_type_prefix^(self#label ?no_ name)
 
     (** Make a correct label from an exception name. *)
-    method exception_label ?no_ name = !Args.latex_exception_prefix^(self#label ?no_ name)
+    method exception_label ?no_ name = !latex_exception_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a type name. *)
-    method type_label ?no_ name = !Args.latex_type_prefix^(self#label ?no_ name)
+    method type_label ?no_ name = !latex_type_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a record field. *)
+    method recfield_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a variant constructor. *)
+    method const_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name)
 
     (** Return latex code for the label of a given label. *)
     method make_label label = "\\label{"^label^"}"
@@ -269,9 +308,9 @@ class text =
       ps fmt "\n\\end{ocamldoccode}\n"
 
     method latex_of_Verbatim fmt s =
-      ps fmt "\\begin{verbatim}";
+      ps fmt "\n\\begin{verbatim}\n";
       ps fmt s;
-      ps fmt "\\end{verbatim}"
+      ps fmt "\n\\end{verbatim}\n"
 
     method latex_of_Bold fmt t =
       ps fmt "{\\bf ";
@@ -377,6 +416,8 @@ class text =
             | Odoc_info.RK_attribute -> self#attribute_label
             | Odoc_info.RK_method -> self#method_label
             | Odoc_info.RK_section _ -> assert false
+            | Odoc_info.RK_recfield -> self#recfield_label
+            | Odoc_info.RK_const -> self#const_label
           in
           let text =
             match text_opt with
@@ -413,6 +454,8 @@ class virtual info =
         (self#text_of_info ~block info_opt)
   end
 
+module Generator =
+struct
 (** This class is used to create objects which can generate a simple LaTeX documentation. *)
 class latex =
   object (self)
@@ -517,12 +560,22 @@ class latex =
                     let s_cons =
                       p fmt2 "@[  | %s" constr.vc_name;
                       (
-                       match constr.vc_args with
-                         [] -> ()
-                       | l ->
+                       match constr.vc_args, constr.vc_ret with
+                         [], None -> ()
+                       | l, None ->
                            p fmt2 " %s@ %s"
                              "of"
                              (self#normal_type_list ~par: false mod_name " * " l)
+                       | [], Some r ->
+                           p fmt2 " %s@ %s"
+                             ":"
+                             (self#normal_type mod_name r)
+                       | l, Some r ->
+                           p fmt2 " %s@ %s@ %s@ %s"
+                             ":"
+                             (self#normal_type_list ~par: false mod_name " * " l)
+			     "->"
+                             (self#normal_type mod_name r)
                       );
                       flush2 ()
                     in
@@ -650,7 +703,7 @@ class latex =
           self#latex_of_module_kind fmt father k2;
           self#latex_of_text fmt [Code ")"]
       | Module_with (k, s) ->
-          (* TODO: à modifier quand Module_with sera plus détaillé *)
+          (* TODO: à modifier quand Module_with sera plus détaillé *)
           self#latex_of_module_type_kind fmt father k;
           self#latex_of_text fmt
             [ Code " ";
@@ -679,7 +732,7 @@ class latex =
           self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
 
       | Class_apply capp ->
-          (* TODO: afficher le type final à partir du typedtree *)
+          (* TODO: afficher le type final à partir du typedtree *)
           self#latex_of_text fmt [Raw "class application not handled yet"]
 
       | Class_constr cco ->
@@ -1078,11 +1131,12 @@ class latex =
       ps fmt "\\documentclass[11pt]{article} \n";
       ps fmt "\\usepackage[latin1]{inputenc} \n";
       ps fmt "\\usepackage[T1]{fontenc} \n";
+      ps fmt "\\usepackage{textcomp}\n";
       ps fmt "\\usepackage{fullpage} \n";
       ps fmt "\\usepackage{url} \n";
       ps fmt "\\usepackage{ocamldoc}\n";
       (
-       match !Args.title with
+       match !Global.title with
          None -> ()
        | Some s ->
            ps fmt "\\title{";
@@ -1090,15 +1144,15 @@ class latex =
            ps fmt "}\n"
       );
       ps fmt "\\begin{document}\n";
-      (match !Args.title with
+      (match !Global.title with
         None -> () |
         Some _ -> ps fmt "\\maketitle\n"
       );
-      if !Args.with_toc then ps fmt "\\tableofcontents\n";
+      if !Global.with_toc then ps fmt "\\tableofcontents\n";
       (
        let info = Odoc_info.apply_opt
            (Odoc_info.info_of_comment_file module_list)
-           !Odoc_info.Args.intro_file
+           !Odoc_info.Global.intro_file
        in
        (match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}");
        self#latex_of_info fmt info;
@@ -1109,7 +1163,7 @@ class latex =
     (** Generate the LaTeX style file, if it does not exists. *)
     method generate_style_file =
       try
-        let dir = Filename.dirname !Args.out_file in
+        let dir = Filename.dirname !Global.out_file in
         let file = Filename.concat dir "ocamldoc.sty" in
         if Sys.file_exists file then
           Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
@@ -1126,12 +1180,12 @@ class latex =
           prerr_endline s ;
           incr Odoc_info.errors ;
 
-    (** Generate the LaTeX file from a module list, in the {!Odoc_info.Args.out_file} file. *)
+    (** Generate the LaTeX file from a module list, in the {!Odoc_info.Global.out_file} file. *)
     method generate module_list =
       self#generate_style_file ;
-      let main_file = !Args.out_file in
+      let main_file = !Global.out_file in
       let dir = Filename.dirname main_file in
-      if !Args.separate_files then
+      if !separate_files then
         (
          let f m =
            try
@@ -1154,16 +1208,16 @@ class latex =
       try
         let chanout = open_out main_file in
         let fmt = Format.formatter_of_out_channel chanout in
-        if !Args.with_header then self#latex_header fmt module_list;
+        if !Global.with_header then self#latex_header fmt module_list;
         List.iter
           (fun m ->
-            if !Args.separate_files then
+            if !separate_files then
               ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n")
             else
               self#generate_for_top_module fmt m
           )
           module_list ;
-        if !Args.with_trailer then ps fmt "\\end{document}";
+        if !Global.with_trailer then ps fmt "\\end{document}";
         Format.pp_print_flush fmt ();
         close_out chanout
       with
@@ -1172,3 +1226,6 @@ class latex =
           prerr_endline s ;
           incr Odoc_info.errors
   end
+end
+
+module type Latex_generator = module type of Generator
diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll
index 7b34b364..318a839f 100644
--- a/ocamldoc/odoc_lexer.mll
+++ b/ocamldoc/odoc_lexer.mll
@@ -178,7 +178,7 @@ and special_comment = parse
            let s2 = lecture_string () in
            let s3 = remove_blanks s2 in
            let s4 =
-             if !Odoc_args.remove_stars then
+             if !Odoc_global.remove_stars then
                remove_stars s3
              else
                s3
@@ -244,14 +244,14 @@ and special_comment_part2 = parse
         if !comments_level = 1 then
           (* finally we return the description we kept *)
           let desc =
-            if !Odoc_args.remove_stars then
+            if !Odoc_global.remove_stars then
               remove_stars !description
              else
               !description
           in
           let remain = lecture_string () in
           let remain2 =
-            if !Odoc_args.remove_stars then
+            if !Odoc_global.remove_stars then
               remove_stars remain
              else
                remain
@@ -322,7 +322,7 @@ and elements = parse
          | "return" ->
              T_RETURN
          | s ->
-             if !Odoc_args.no_custom_tags then
+             if !Odoc_global.no_custom_tags then
                raise (Failure (Odoc_messages.not_a_valid_tag s))
              else
                T_CUSTOM s
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index eb6ec4d7..dae2ff98 100644
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -21,6 +21,11 @@ open Class
 open Module
 open Search
 
+let man_suffix = ref Odoc_messages.default_man_suffix
+let man_section = ref Odoc_messages.default_man_section
+
+let man_mini = ref false
+
 let new_buf () = Buffer.create 1024
 let bp = Printf.bprintf
 let bs = Buffer.add_string
@@ -202,6 +207,9 @@ class virtual info =
           self#man_of_custom b info.M.i_custom
   end
 
+module Generator =
+struct
+
 (** This class is used to create objects which can generate a simple html documentation. *)
 class man =
   let re_slash = Str.regexp_string "/" in
@@ -210,7 +218,7 @@ class man =
 
     (** Get a file name from a complete name. *)
     method file_name name =
-      let s = Printf.sprintf "%s.%s" name !Args.man_suffix in
+      let s = Printf.sprintf "%s.%s" name !man_suffix in
       Str.global_replace re_slash "slash" s
 
     (** Escape special sequences of characters in a string. *)
@@ -229,7 +237,7 @@ class man =
 
     (** Open a file for output. Add the target directory.*)
     method open_out file =
-      let f = Filename.concat !Args.target_dir file in
+      let f = Filename.concat !Global.target_dir file in
       open_out f
 
     (** Print groff string for a text, without correction of blanks. *)
@@ -453,23 +461,49 @@ class man =
             (fun constr ->
               bs b ("| "^constr.vc_name);
               (
-               match constr.vc_args, constr.vc_text with
-                 [], None -> bs b "\n "
-               | [], (Some t) ->
+               match constr.vc_args, constr.vc_text,constr.vc_ret with
+               | [], None, None -> bs b "\n "
+               | [], (Some t), None ->
                    bs b "  (* ";
                    self#man_of_text b t;
                    bs b " *)\n "
-               | l, None ->
+               | l, None, None ->
                    bs b "\n.B of ";
                    self#man_of_type_expr_list ~par: false b father " * " l;
                    bs b " "
-               | l, (Some t) ->
+               | l, (Some t), None ->
                    bs b "\n.B of ";
                    self#man_of_type_expr_list ~par: false b father " * " l;
                    bs b ".I \"  \"\n";
                    bs b "(* ";
                    self#man_of_text b t;
                    bs b " *)\n "
+               | [], None, Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr b father r;
+                   bs b " "
+               | [], (Some t), Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr b father r;
+                   bs b ".I \"  \"\n";
+                   bs b "(* ";
+                   self#man_of_text b t;
+                   bs b " *)\n "
+               | l, None, Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr_list ~par: false b father " * " l;
+		   bs b ".B -> ";
+                   self#man_of_type_expr b father r;
+                   bs b " "
+               | l, (Some t), Some r ->
+                   bs b "\n.B of ";
+                   self#man_of_type_expr_list ~par: false b father " * " l;
+		   bs b ".B -> ";
+                   self#man_of_type_expr b father r;
+                   bs b ".I \"  \"\n";
+                   bs b "(* ";
+                   self#man_of_text b t;
+                   bs b " *)\n "
               )
             )
             l
@@ -693,10 +727,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^cl.cl_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match cl.cl_info with
@@ -752,10 +786,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^ct.clt_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match ct.clt_info with
@@ -809,10 +843,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^mt.mt_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match mt.mt_info with
@@ -887,10 +921,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^m.m_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match m.m_info with
@@ -965,6 +999,8 @@ class man =
         | Res_attribute a -> Name.simple a.att_value.val_name
         | Res_method m -> Name.simple m.met_value.val_name
         | Res_section _ -> assert false
+        | Res_recfield (_,f) -> f.rf_name
+        | Res_const (_,f) -> f.vc_name
       in
       let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*")  in
       let all_items = List.filter
@@ -1006,6 +1042,8 @@ class man =
           | Res_attribute a -> a.att_value.val_name
           | Res_method m -> m.met_value.val_name
           | Res_section (s,_) -> s
+          | Res_recfield (_,f) -> f.rf_name
+          | Res_const (_,f) -> f.vc_name
          )
      in
      let date = Unix.time () in
@@ -1014,10 +1052,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
         bs b ".SH NAME\n";
         bs b (name^" \\- all "^name^" elements\n\n");
 
@@ -1069,10 +1107,13 @@ class man =
         | [Res_class cl] -> self#generate_for_class cl
         | [Res_class_type ct] -> self#generate_for_class_type ct
         | l ->
-            if !Args.man_mini then
+            if !man_mini then
               ()
             else
               self#generate_for_group l
       in
       List.iter f groups
   end
+end
+
+module type Man_generator = module type of Generator
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index 7e81159b..4c6b452c 100644
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -253,7 +253,7 @@ let merge_types merge_options mli ml =
           cons.vc_text <- new_desc
         with
           Not_found ->
-            if !Odoc_args.inverse_merge_ml_mli then
+            if !Odoc_global.inverse_merge_ml_mli then
               ()
             else
               raise (Failure (Odoc_messages.different_types mli.ty_name))
@@ -281,7 +281,7 @@ let merge_types merge_options mli ml =
           record.rf_text <- new_desc
         with
           Not_found ->
-            if !Odoc_args.inverse_merge_ml_mli then
+            if !Odoc_global.inverse_merge_ml_mli then
               ()
             else
               raise (Failure (Odoc_messages.different_types mli.ty_name))
@@ -289,7 +289,7 @@ let merge_types merge_options mli ml =
       List.iter f l1
 
   | _ ->
-      if !Odoc_args.inverse_merge_ml_mli then
+      if !Odoc_global.inverse_merge_ml_mli then
         ()
       else
         raise (Failure (Odoc_messages.different_types mli.ty_name))
@@ -357,7 +357,7 @@ let merge_classes merge_options mli ml =
                      a.att_value.val_info <- merge_info_opt merge_options
                          a.att_value.val_info a2.att_value.val_info;
                      a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ;
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        a.att_value.val_code <- a2.att_value.val_code;
                      true
                     )
@@ -396,7 +396,7 @@ let merge_classes merge_options mli ml =
                         parameters because the associated comment of a parameter may have been changed by the merge.*)
                      Odoc_value.update_value_parameters_text m.met_value;
 
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        m.met_value.val_code <- m2.met_value.val_code;
 
                      true
@@ -434,7 +434,7 @@ let merge_class_types merge_options mli ml =
                      a.att_value.val_info <- merge_info_opt merge_options
                          a.att_value.val_info a2.att_value.val_info;
                      a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ;
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        a.att_value.val_code <- a2.att_value.val_code;
 
                      true
@@ -473,7 +473,7 @@ let merge_class_types merge_options mli ml =
                         parameters because the associated comment of a parameter may have been changed y the merge.*)
                      Odoc_value.update_value_parameters_text m.met_value;
 
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        m.met_value.val_code <- m2.met_value.val_code;
 
                      true
@@ -637,7 +637,7 @@ let rec merge_module_types merge_options mli ml =
                         parameters because the associated comment of a parameter may have been changed y the merge.*)
                      Odoc_value.update_value_parameters_text v;
 
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        v.val_code <- v2.val_code;
 
                      true
@@ -727,7 +727,7 @@ and merge_modules merge_options mli ml =
   mli.m_top_deps <- remove_doubles mli.m_top_deps ml.m_top_deps ;
 
   let code =
-    if !Odoc_args.keep_code then
+    if !Odoc_global.keep_code then
       match mli.m_code, ml.m_code with
         Some s, _ -> Some s
       | _, Some s -> Some s
@@ -736,7 +736,7 @@ and merge_modules merge_options mli ml =
       None
   in
   let code_intf =
-    if !Odoc_args.keep_code then
+    if !Odoc_global.keep_code then
       match mli.m_code_intf, ml.m_code_intf with
         Some s, _ -> Some s
       | _, Some s -> Some s
@@ -883,7 +883,7 @@ and merge_modules merge_options mli ml =
                     parameters because the associated comment of a parameter may have been changed y the merge.*)
                  Odoc_value.update_value_parameters_text v;
 
-                 if !Odoc_args.keep_code then
+                 if !Odoc_global.keep_code then
                    v.val_code <- v2.val_code;
                  true
                 )
@@ -975,19 +975,19 @@ let merge merge_options modules_list =
             (
              (* we can merge m with m2 if there is an implementation
                 and an interface.*)
-             let f b = if !Odoc_args.inverse_merge_ml_mli then not b else b in
+             let f b = if !Odoc_global.inverse_merge_ml_mli then not b else b in
              match f m.m_is_interface, f m2.m_is_interface with
                true, false -> (merge_modules merge_options m m2) :: (iter l_others)
              | false, true -> (merge_modules merge_options m2 m) :: (iter l_others)
              | false, false ->
-                 if !Odoc_args.inverse_merge_ml_mli then
+                 if !Odoc_global.inverse_merge_ml_mli then
                    (* two Module.ts for the .mli ! *)
                    raise (Failure (Odoc_messages.two_interfaces m.m_name))
                  else
                    (* two Module.t for the .ml ! *)
                    raise (Failure (Odoc_messages.two_implementations m.m_name))
              | true, true ->
-                 if !Odoc_args.inverse_merge_ml_mli then
+                 if !Odoc_global.inverse_merge_ml_mli then
                    (* two Module.t for the .ml ! *)
                    raise (Failure (Odoc_messages.two_implementations m.m_name))
                  else
diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli
index 4f580ee8..3133c5e9 100644
--- a/ocamldoc/odoc_merge.mli
+++ b/ocamldoc/odoc_merge.mli
@@ -13,7 +13,7 @@
 
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
-(** Merging \@before tags. *)
+(** Merging \@before tags. *)
 val merge_before_tags :
     (string * Odoc_types.text) list -> (string * Odoc_types.text) list
 
diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
index 18a1cb4b..7dfdff49 100644
--- a/ocamldoc/odoc_messages.ml
+++ b/ocamldoc/odoc_messages.ml
@@ -127,6 +127,11 @@ let latex_type_prefix =
   "\n\t\tUse  as prefix for the LaTeX labels of types.\n"^
   "\t\t(default is \""^default_latex_type_prefix^"\")"
 
+let default_latex_type_elt_prefix = "typeelt:"
+let latex_type_elt_prefix =
+  "\n\t\tUse  as prefix for the LaTeX labels of type elements.\n"^
+  "\t\t(default is \""^default_latex_type_elt_prefix^"\")"
+
 let default_latex_exception_prefix = "exception:"
 let latex_exception_prefix =
   "\n\t\tUse  as prefix for the LaTeX labels of exceptions.\n"^
@@ -218,9 +223,6 @@ let help = "\t\tDisplay this list of options"
 (** Error and warning messages *)
 
 let warning = "Warning"
-let pwarning s =
-  if !Odoc_config.print_warnings then prerr_endline (warning^": "^s);
-  if !Odoc_global.warn_error then incr Odoc_global.errors
 
 let bad_magic_number =
   "Bad magic number for this ocamldoc dump!\n"^
@@ -247,7 +249,7 @@ let tag_not_handled tag = "Tag @"^tag^" not handled by this generator"
 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.";;
-let method_without_param f = "Méthode "^f^" has no parameter.";;
+let method_without_param f = "Method "^f^" has no parameter.";;
 let anonymous_parameters f = "Function "^f^" has anonymous parameters."
 let function_colon f = "Function "^f^": "
 let implicit_match_in_parameter = "Parameters contain implicit pattern matching."
@@ -297,11 +299,17 @@ let cross_attribute_not_found n = "Attribute "^n^" not found"
 let cross_section_not_found n = "Section "^n^" not found"
 let cross_value_not_found n = "Value "^n^" not found"
 let cross_type_not_found n = "Type "^n^" not found"
+let cross_recfield_not_found n = Printf.sprintf "Record field %s not found" n
+let cross_const_not_found n = Printf.sprintf "Constructor %s not found" n
 
 let object_end = "object ... end"
 let struct_end = "struct ... end"
 let sig_end = "sig ... end"
 
+let current_generator_is_not kind =
+  Printf.sprintf "Current generator is not a %s generator" kind
+;;
+
 (** Messages for verbose mode. *)
 
 let analysing f = "Analysing file "^f^"..."
diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
index c439ef31..c74b287d 100644
--- a/ocamldoc/odoc_misc.ml
+++ b/ocamldoc/odoc_misc.ml
@@ -334,7 +334,7 @@ let rec get_before_dot s =
     let len = String.length s in
     let n = String.index s '.' in
     if n + 1 >= len then
-      (* le point est le dernier caractère *)
+      (* le point est le dernier caractère *)
       (true, s, "")
     else
       match s.[n+1] with
@@ -478,8 +478,8 @@ let remove_option typ =
     match t with
     | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
     | Types.Tconstr _
-    | Types.Tvar
-    | Types.Tunivar
+    | Types.Tvar _
+    | Types.Tunivar _
     | Types.Tpoly _
     | Types.Tarrow _
     | Types.Ttuple _
diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index 5cc8e038..88e34957 100644
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -82,7 +82,7 @@ let simpl_class_type t =
     match t with
       Types.Tcty_constr (p,texp_list,ct) -> t
     | Types.Tcty_signature cs ->
-        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
+        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
            quand on affichera le type *)
         let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
         Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with
diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 29e1ca27..18a8f117 100644
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -28,7 +28,18 @@ class scanner =
   (** Scan of 'leaf elements'. *)
 
     method scan_value (v : Odoc_value.t_value) = ()
-    method scan_type (t : Odoc_type.t_type) = ()
+
+    method scan_type_pre (t : Odoc_type.t_type) = true
+
+    method scan_type_recfield t (f : Odoc_type.record_field) = ()
+    method scan_type_const t (f : Odoc_type.variant_constructor) = ()
+    method scan_type (t : Odoc_type.t_type) =
+      if self#scan_type_pre t then
+        match t.Odoc_type.ty_kind with
+          Odoc_type.Type_abstract -> ()
+        | Odoc_type.Type_variant l -> List.iter (self#scan_type_const t) l
+        | Odoc_type.Type_record l -> List.iter (self#scan_type_recfield t) l
+
     method scan_exception (e : Odoc_exception.t_exception) = ()
     method scan_attribute (a : Odoc_value.t_attribute) = ()
     method scan_method (m : Odoc_value.t_method) = ()
@@ -45,7 +56,7 @@ class scanner =
     method scan_class_pre (c : Odoc_class.t_class) = true
 
     (** This method scan the elements of the given class.
-       A VOIR : scan des classes héritées.*)
+       A VOIR : scan des classes héritées.*)
     method scan_class_elements c =
       List.iter
         (fun ele ->
@@ -71,7 +82,7 @@ class scanner =
     method scan_class_type_pre (ct : Odoc_class.t_class_type) = true
 
     (** This method scan the elements of the given class type.
-       A VOIR : scan des classes héritées.*)
+       A VOIR : scan des classes héritées.*)
     method scan_class_type_elements ct =
       List.iter
         (fun ele ->
diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
index 65d602d3..91b1d13c 100644
--- a/ocamldoc/odoc_search.ml
+++ b/ocamldoc/odoc_search.ml
@@ -32,6 +32,8 @@ type result_element =
   | Res_attribute of t_attribute
   | Res_method of t_method
   | Res_section of string * Odoc_types.text
+  | Res_recfield of t_type * record_field
+  | Res_const of t_type * variant_constructor
 
 type result = result_element list
 
@@ -43,7 +45,9 @@ module type Predicates =
     val p_class : t_class -> t -> bool * bool
     val p_class_type : t_class_type -> t -> bool * bool
     val p_value : t_value -> t -> bool
-    val p_type : t_type -> t -> bool
+    val p_recfield : t_type -> record_field -> t -> bool
+    val p_const : t_type -> variant_constructor -> t -> bool
+    val p_type : t_type -> t -> (bool * bool)
     val p_exception : t_exception -> t -> bool
     val p_attribute : t_attribute -> t -> bool
     val p_method : t_method -> t -> bool
@@ -92,7 +96,26 @@ module Search =
 
     let search_value va v = if P.p_value va v then [Res_value va] else []
 
-    let search_type t v = if P.p_type t v then [Res_type t] else []
+    let search_recfield t f v =
+      if P.p_recfield t f v then [Res_recfield (t,f)] else []
+
+    let search_const t f v =
+      if P.p_const t f v then [Res_const (t,f)] else []
+
+    let search_type t v =
+      let (go_deeper, ok) = P.p_type t v in
+      let l =
+        match go_deeper with
+          false -> []
+        | true ->
+            match t.ty_kind with
+              Type_abstract -> []
+            | Type_record l ->
+                List.flatten (List.map (fun rf -> search_recfield t rf v) l)
+            | Type_variant l ->
+                List.flatten (List.map (fun rf -> search_const t rf v) l)
+      in
+      if ok then (Res_type t) :: l else l
 
     let search_exception e v = if P.p_exception e v then [Res_exception e] else []
 
@@ -305,7 +328,13 @@ module P_name =
     let p_class c r = (true, c.cl_name =~ r)
     let p_class_type ct r = (true, ct.clt_name =~ r)
     let p_value v r = v.val_name =~ r
-    let p_type t r = t.ty_name =~ r
+    let p_recfield t f r =
+      let name = Printf.sprintf "%s.%s" t.ty_name f.rf_name in
+      name =~ r
+    let p_const t f r =
+      let name = Printf.sprintf "%s.%s" t.ty_name f.vc_name in
+      name =~ r
+    let p_type t r = (true, t.ty_name =~ r)
     let p_exception e r = e.ex_name =~ r
     let p_attribute a r = a.att_value.val_name =~ r
     let p_method m r = m.met_value.val_name =~ r
@@ -322,7 +351,9 @@ module P_values =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = true
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -347,7 +378,9 @@ module P_exceptions =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = true
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -372,7 +405,9 @@ module P_types =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = true
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, true)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -397,7 +432,9 @@ module P_attributes =
     let p_class _ _ = (true, false)
     let p_class_type _ _ = (true, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = true
     let p_method _ _ = false
@@ -422,7 +459,9 @@ module P_methods =
     let p_class _ _ = (true, false)
     let p_class_type _ _ = (true, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = true
@@ -447,7 +486,9 @@ module P_classes =
     let p_class _ _ = (false, true)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -472,7 +513,9 @@ module P_class_types =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, true)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -497,7 +540,9 @@ module P_modules =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -522,7 +567,9 @@ module P_module_types =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli
index d7ace583..2f882d52 100644
--- a/ocamldoc/odoc_search.mli
+++ b/ocamldoc/odoc_search.mli
@@ -25,6 +25,8 @@ type result_element =
   | Res_attribute of Odoc_value.t_attribute
   | Res_method of Odoc_value.t_method
   | Res_section of string * Odoc_types.text
+  | Res_recfield of  Odoc_type.t_type * Odoc_type.record_field
+  | Res_const of  Odoc_type.t_type * Odoc_type.variant_constructor
 
 (** The type representing a research result.*)
 type result = result_element list
@@ -42,7 +44,9 @@ module type Predicates =
     val p_class : Odoc_class.t_class -> t -> bool * bool
     val p_class_type : Odoc_class.t_class_type -> t -> bool * bool
     val p_value : Odoc_value.t_value -> t -> bool
-    val p_type : Odoc_type.t_type -> t -> bool
+    val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> t -> bool
+    val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> t -> bool
+    val p_type : Odoc_type.t_type -> t -> (bool * bool)
     val p_exception : Odoc_exception.t_exception -> t -> bool
     val p_attribute : Odoc_value.t_attribute -> t -> bool
     val p_method : Odoc_value.t_method -> t -> bool
@@ -59,6 +63,14 @@ module Search :
       (** search in a value *)
       val search_value : Odoc_value.t_value -> P.t -> result_element list
 
+      (** search in a record field *)
+      val search_recfield :
+        Odoc_type.t_type -> Odoc_type.record_field -> P.t -> result_element list
+
+      (** search in a variant constructor *)
+      val search_const :
+        Odoc_type.t_type -> Odoc_type.variant_constructor -> P.t -> result_element list
+
       (** search in a type *)
       val search_type : Odoc_type.t_type -> P.t -> result_element list
 
@@ -102,7 +114,9 @@ module P_name :
     val p_class : Odoc_class.t_class -> Str.regexp -> bool * bool
     val p_class_type : Odoc_class.t_class_type -> Str.regexp -> bool * bool
     val p_value : Odoc_value.t_value -> Str.regexp -> bool
-    val p_type : Odoc_type.t_type -> Str.regexp -> bool
+    val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> Str.regexp -> bool
+    val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> Str.regexp -> bool
+    val p_type : Odoc_type.t_type -> Str.regexp -> (bool * bool)
     val p_exception : Odoc_exception.t_exception -> Str.regexp -> bool
     val p_attribute : Odoc_value.t_attribute -> Str.regexp -> bool
     val p_method : Odoc_value.t_method -> Str.regexp -> bool
@@ -113,6 +127,8 @@ module Search_by_name :
   sig
     val search_section : Odoc_types.text -> string -> P_name.t -> result_element list
     val search_value : Odoc_value.t_value -> P_name.t -> result_element list
+    val search_recfield : Odoc_type.t_type -> Odoc_type.record_field -> P_name.t -> result_element list
+    val search_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> P_name.t -> result_element list
     val search_type : Odoc_type.t_type -> P_name.t -> result_element list
     val search_exception :
       Odoc_exception.t_exception -> P_name.t -> result_element list
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 34a71e84..75845bc6 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -179,21 +179,21 @@ module Analyser =
             match cons_core_type_list_list with
               [] ->
                 (0, acc)
-            | (name, core_type_list, loc) :: [] ->
+            | (name, _, _, loc) :: [] ->
                 let s = get_string_of_file
                     loc.Location.loc_end.Lexing.pos_cnum
                     pos_limit
                 in
                 let (len, comment_opt) =  My_ir.just_after_special !file_name s in
                 (len, acc @ [ (name, comment_opt) ])
-            | (name, core_type_list, loc) :: (name2, core_type_list2, loc2)
+            | (name, _, _, loc) :: (name2, core_type_list2, ret_type2, loc2)
               :: q ->
                 let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in
                 let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in
                 let s = get_string_of_file pos_end_first pos_start_second in
                 let (_,comment_opt) = My_ir.just_after_special !file_name  s in
                 f (acc @ [name, comment_opt])
-                  ((name2, core_type_list2, loc2) :: q)
+                  ((name2, core_type_list2, ret_type2, loc2) :: q)
           in
           f [] cons_core_type_list_list
 
@@ -219,9 +219,8 @@ module Analyser =
       match type_kind with
         Types.Type_abstract ->
           Odoc_type.Type_abstract
-
       | Types.Type_variant l ->
-          let f (constructor_name, type_expr_list) =
+          let f (constructor_name, type_expr_list, ret_type) =
             let comment_opt =
               try
                 match List.assoc constructor_name name_comment_list with
@@ -232,6 +231,7 @@ module Analyser =
             {
               vc_name = constructor_name ;
               vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
+	      vc_ret =  may_map (Odoc_env.subst_type env) ret_type;
               vc_text = comment_opt
             }
           in
@@ -524,12 +524,12 @@ module Analyser =
               {
                 ex_name = Name.concat current_module_name name ;
                 ex_info = comment_opt ;
-                ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ;
+                ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ;
                 ex_alias = None ;
                 ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
                 ex_code =
                    (
-                    if !Odoc_args.keep_code then
+                    if !Odoc_global.keep_code then
                       Some (get_string_of_file pos_start_ele pos_end_ele)
                     else
                       None
@@ -617,7 +617,7 @@ module Analyser =
                       };
                       ty_code =
                         (
-                         if !Odoc_args.keep_code then
+                         if !Odoc_global.keep_code then
                            Some (get_string_of_file loc_start new_end)
                          else
                            None
@@ -660,7 +660,7 @@ module Analyser =
             in
             let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
             let code_intf =
-              if !Odoc_args.keep_code then
+              if !Odoc_global.keep_code then
                 let loc = module_type.Parsetree.pmty_loc in
                 let st = loc.Location.loc_start.Lexing.pos_cnum in
                 let en = loc.Location.loc_end.Lexing.pos_cnum in
@@ -691,7 +691,7 @@ module Analyser =
             new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
             let new_env = Odoc_env.add_module env new_module.m_name in
             let new_env2 =
-              match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+              match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                 Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s
               | _ -> new_env
             in
@@ -711,7 +711,7 @@ module Analyser =
                       raise (Failure (Odoc_messages.module_not_found current_module_name name))
                   in
                   match sig_module_type with
-                    (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+                    (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                     Types.Tmty_signature s ->
                       Odoc_env.add_signature e complete_name ~rel: name s
                   | _ ->
@@ -751,7 +751,7 @@ module Analyser =
                   (* associate the comments to each constructor and build the [Type.t_type] *)
                   let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
                   let code_intf =
-                    if !Odoc_args.keep_code then
+                    if !Odoc_global.keep_code then
                       let loc = modtype.Parsetree.pmty_loc in
                       let st = loc.Location.loc_start.Lexing.pos_cnum in
                       let en = loc.Location.loc_end.Lexing.pos_cnum in
@@ -826,7 +826,7 @@ module Analyser =
             mt.mt_info <- merge_infos mt.mt_info info_after_opt ;
             let new_env = Odoc_env.add_module_type env mt.mt_name in
             let new_env2 =
-              match sig_mtype with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+              match sig_mtype with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                 Some (Types.Tmty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
               | _ -> new_env
             in
@@ -856,7 +856,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 : étendre l'environnement ? avec quoi ? *)
 
         | Parsetree.Psig_class class_description_list ->
             (* we start by extending the environment *)
@@ -1179,7 +1179,7 @@ module Analyser =
           ([], Class_structure (inher_l, ele))
 
       | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) ->
-          (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *)
+          (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *)
           (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *)
           if parse_label = label then
             (
@@ -1195,7 +1195,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 différents")
             )
 
       | _ ->
@@ -1283,7 +1283,7 @@ module Analyser =
         analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast
       in
       let code_intf =
-        if !Odoc_args.keep_code then
+        if !Odoc_global.keep_code then
           Some !file
         else
           None
diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index b20cd8b4..d420c059 100644
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -31,7 +31,7 @@ let rec is_arrow_type t =
   | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
   | Types.Ttuple _
   | Types.Tconstr _
-  | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
+  | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
   | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
 
 let raw_string_of_type_list sep type_list =
@@ -43,7 +43,7 @@ let raw_string_of_type_list sep type_list =
     | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
     | Types.Tconstr _ ->
         false
-    | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
+    | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
     | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
   in
   let print_one_type variance t =
@@ -183,11 +183,20 @@ let string_of_type t =
          (List.map
             (fun cons ->
               "  | "^cons.M.vc_name^
-              (match cons.M.vc_args with
-                [] -> ""
-              | l ->
-                  " of "^(String.concat " * "
-                            (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))
+              (match cons.M.vc_args,cons.M.vc_ret with
+              | [], None -> ""
+              | l, None ->
+                  " of " ^
+                  (String.concat " * "
+                     (List.map
+                        (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
+              | [], Some r -> " : " ^ Odoc_print.string_of_type_expr r
+              | l, Some r ->
+                  " : " ^
+                  (String.concat " * "
+                     (List.map
+                        (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
+                  ^ " -> " ^ Odoc_print.string_of_type_expr r
               )^
               (match cons.M.vc_text with
                 None ->
@@ -205,7 +214,8 @@ let string_of_type t =
          (List.map
             (fun record ->
               "   "^(if record.M.rf_mutable then "mutable " else "")^
-              record.M.rf_name^" : "^(Odoc_print.string_of_type_expr record.M.rf_type)^";"^
+              record.M.rf_name^" : "^
+              (Odoc_print.string_of_type_expr record.M.rf_type)^";"^
               (match record.M.rf_text with
                 None ->
                   ""
diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
index a9868f6e..a903b1c1 100644
--- a/ocamldoc/odoc_test.ml
+++ b/ocamldoc/odoc_test.ml
@@ -22,10 +22,13 @@ type test_kind =
 
 let p = Format.fprintf
 
-class string_gen =
+module Generator (G : Odoc_gen.Base) =
+struct
+  class string_gen =
   object(self)
     inherit Odoc_info.Scan.scanner
 
+
     val mutable test_kinds = []
     val mutable fmt = Format.str_formatter
 
@@ -88,7 +91,7 @@ class string_gen =
       true
 
     method generate (module_list: Odoc_info.Module.t_module list) =
-      let oc = open_out !Odoc_info.Args.out_file in
+      let oc = open_out !Odoc_info.Global.out_file in
       fmt <- Format.formatter_of_out_channel oc;
       (
        try
@@ -106,7 +109,15 @@ class string_gen =
       close_out oc
   end
 
+  class generator =
+    let g = new string_gen in
+    object
+      inherit G.generator as base
+
+      method generate l =
+        base#generate l;
+        g#generate l
+    end
+end;;
 
-let my_generator = new string_gen
-let _ = Odoc_info.Args.set_doc_generator
-    (Some (my_generator :> Odoc_info.Args.doc_generator))
+let _ = Odoc_args.extend_base_generator (module Generator : Odoc_gen.Base_functor);;
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index a853c4f7..5c75b4fd 100644
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -1,11 +1,12 @@
 (***********************************************************************)
-(*                           OCamldoc                                  *)
+(*                             OCamldoc                                *)
 (*                                                                     *)
 (*      Olivier Andrieu, base sur du code de Maxence Guesdon           *)
 (*                                                                     *)
 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
 (*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
 (***********************************************************************)
 
 (* $Id$ *)
@@ -20,6 +21,12 @@ open Exception
 open Class
 open Module
 
+let esc_8bits = ref false
+
+let info_section = ref "OCaml"
+
+let info_entry = ref []
+
 (** {2 Some small helper functions} *)
 
 let puts_nl chan s =
@@ -140,7 +147,7 @@ struct
     (Str.regexp "}", "@}") ;
     (Str.regexp "\\.\\.\\.", "@dots{}") ;
   ] @
-    (if !Args.esc_8bits
+    (if !esc_8bits
     then [
     (Str.regexp "à", "@`a") ;
     (Str.regexp "â", "@^a") ;
@@ -381,6 +388,9 @@ class text =
 
 exception Aliased_node
 
+module Generator =
+struct
+
 (** This class is used to create objects which can generate a simple
     Texinfo documentation. *)
 class texi =
@@ -413,7 +423,7 @@ class texi =
 
     method index (ind : indices) ent =
       Verbatim
-        (if !Args.with_index
+        (if !Global.with_index
         then (assert(List.mem ind indices_to_build) ;
               String.concat ""
                 [ "@" ; indices ind ; "index " ;
@@ -630,9 +640,13 @@ class texi =
           Printf.sprintf "(%s) "
             (String.concat ", " (List.map f l))
 
-    method string_of_type_args = function
-      | [] -> ""
-      | args -> " of " ^ (Odoc_info.string_of_type_list " * " args)
+    method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = 
+      match args, ret with
+      | [], None -> ""
+      | args, None -> " of " ^ (Odoc_info.string_of_type_list " * " args)
+      | [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r)
+      | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ 
+	                        " -> " ^ (Odoc_info.string_of_type_expr r)
 
     (** Return Texinfo code for a type. *)
     method texi_of_type ty =
@@ -658,11 +672,13 @@ class texi =
                   (List.map
                      (fun constr ->
                        (Raw ("  | " ^ constr.vc_name)) ::
-                       (Raw (self#string_of_type_args constr.vc_args)) ::
+                       (Raw (self#string_of_type_args
+                               constr.vc_args constr.vc_ret)) ::
                        (match constr.vc_text with
                        | None -> [ Newline ]
                        | Some t ->
-                           ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @
+                           (Raw (indent 5 "\n(* ") ::
+                            self#soft_fix_linebreaks 8 t) @
                            [ Raw " *)" ; Newline ]
                        ) ) l ) )
            | Type_record l ->
@@ -694,7 +710,7 @@ class texi =
         [ self#fixedblock
             ( [ Newline ; minus ; Raw "exception " ;
                 Raw (Name.simple e.ex_name) ;
-                Raw (self#string_of_type_args e.ex_args) ] @
+                Raw (self#string_of_type_args e.ex_args None) ] @
               (match e.ex_alias with
               | None -> []
               | Some ea -> [ Raw " = " ; Raw
@@ -1055,7 +1071,7 @@ class texi =
 
     (** Writes the header of the TeXinfo document. *)
     method generate_texi_header chan texi_filename m_list =
-      let title = match !Args.title with
+      let title = match !Global.title with
       | None -> ""
       | Some s -> self#escape s in
       let filename =
@@ -1080,18 +1096,18 @@ class texi =
                "@settitle " ^ title ;
                "@c %**end of header" ; ] ;
 
-             (if !Args.with_index then
+             (if !Global.with_index then
                List.map
                  (fun ind ->
                    "@defcodeindex " ^ (indices ind))
                  indices_to_build
              else []) ;
 
-             [ Texi.dirsection !Args.info_section ] ;
+             [ Texi.dirsection !info_section ] ;
 
              Texi.direntry
-               (if !Args.info_entry <> []
-               then !Args.info_entry
+               (if !info_entry <> []
+               then !info_entry
                else [ Printf.sprintf "* %s: (%s)."
                         title
                         (Filename.chop_suffix filename ".info") ]) ;
@@ -1108,7 +1124,7 @@ class texi =
 
       (* insert the intro file *)
       begin
-        match !Odoc_info.Args.intro_file with
+        match !Odoc_info.Global.intro_file with
         | None when title <> "" ->
             puts_nl chan "@ifinfo" ;
             puts_nl chan ("Documentation for " ^ title) ;
@@ -1125,7 +1141,7 @@ class texi =
       (* write a top menu *)
       Texi.generate_menu chan
         ((List.map (fun m -> `Module m) m_list) @
-         (if !Args.with_index then
+         (if !Global.with_index then
            let indices_names_to_build = List.map indices indices_to_build in
            List.rev
              (List.fold_left
@@ -1142,7 +1158,7 @@ class texi =
     (** Writes the trailer of the TeXinfo document. *)
     method generate_texi_trailer chan =
       nl chan ;
-      if !Args.with_index
+      if !Global.with_index
       then
         let indices_names_to_build = List.map indices indices_to_build in
         List.iter (puts_nl chan)
@@ -1155,7 +1171,7 @@ class texi =
                          "@printindex " ^ shortname ; ]
                   else [])
                 indices_names )) ;
-      if !Args.with_toc
+      if !Global.with_toc
       then puts_nl chan "@contents" ;
       puts_nl chan "@bye"
 
@@ -1203,25 +1219,25 @@ class texi =
 
 
     (** Generate the Texinfo file from a module list,
-       in the {!Odoc_info.Args.out_file} file. *)
+       in the {!Odoc_info.Global.out_file} file. *)
     method generate module_list =
       Hashtbl.clear node_tbl ;
       let filename =
-        if !Args.out_file = Odoc_messages.default_out_file
+        if !Global.out_file = Odoc_messages.default_out_file
         then "ocamldoc.texi"
-        else !Args.out_file in
-      if !Args.with_index
+        else !Global.out_file in
+      if !Global.with_index
       then List.iter self#scan_for_index
           (List.map (fun m -> `Module m) module_list) ;
       try
         let chanout = open_out
-            (Filename.concat !Args.target_dir filename) in
-        if !Args.with_header
+            (Filename.concat !Global.target_dir filename) in
+        if !Global.with_header
         then self#generate_texi_header chanout filename module_list ;
         List.iter
           (self#generate_for_module chanout)
           module_list ;
-        if !Args.with_trailer
+        if !Global.with_trailer
         then self#generate_texi_trailer chanout ;
         close_out chanout
       with
@@ -1230,3 +1246,6 @@ class texi =
           prerr_endline s ;
           incr Odoc_info.errors
   end
+end
+
+module type Texi_generator = module type of Generator
diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml
index b50a2dbd..e80b680e 100644
--- a/ocamldoc/odoc_text.ml
+++ b/ocamldoc/odoc_text.ml
@@ -133,6 +133,8 @@ module Texter =
                    | RK_attribute -> "attribute"
                    | RK_method -> "method"
                    | RK_section _ -> "section"
+                   | RK_recfield -> "recfield"
+                   | RK_const -> "const"
                  in
                  s^":"
             )
diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll
index f229f08a..a4888c1a 100644
--- a/ocamldoc/odoc_text_lexer.mll
+++ b/ocamldoc/odoc_text_lexer.mll
@@ -22,10 +22,10 @@ let char_number = ref 0
 
 let string_buffer = Buffer.create 32
 
-(** Fonction de remise à zéro de la chaine de caractères tampon *)
+(** Fonction de remise à zéro de la chaine de caractères tampon *)
 let reset_string_buffer () = Buffer.reset string_buffer
 
-(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *)
+(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *)
 let ajout_char_string = Buffer.add_char string_buffer
 
 (** Add a string to the buffer. *)
@@ -161,6 +161,8 @@ let begin_clt_ref = "{!classtype:"blank_nl | "{!classtype:"
 let begin_att_ref = "{!attribute:"blank_nl | "{!attribute:"
 let begin_met_ref = "{!method:"blank_nl | "{!method:"
 let begin_sec_ref = "{!section:"blank_nl | "{!section:"
+let begin_recf_ref = "{!recfield:"blank_nl | "{!recfield:"
+let begin_const_ref = "{!const:"blank_nl | "{!const:"
 let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:"
 let index_list = "{!indexlist}"
 let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']*
@@ -664,7 +666,38 @@ rule main = parse
            Char (Lexing.lexeme lexbuf)
           )
     }
-
+| begin_recf_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           RECF_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+| begin_const_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           CONST_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
 | begin_mod_list_ref
     {
       incr_cpts lexbuf ;
@@ -720,7 +753,10 @@ rule main = parse
 | shortcut_list_item
     {
       incr_cpts lexbuf ;
-      if !shortcut_list_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode
+          || !ele_ref_mode || !verb_mode then
+        Char (Lexing.lexeme lexbuf)
+      else if !shortcut_list_mode then
         (
          SHORTCUT_LIST_ITEM
         )
@@ -734,7 +770,10 @@ rule main = parse
 | shortcut_enum_item
     {
       incr_cpts lexbuf ;
-      if !shortcut_list_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode
+         || !ele_ref_mode || !verb_mode then
+        Char (Lexing.lexeme lexbuf)
+      else if !shortcut_list_mode then
         SHORTCUT_ENUM_ITEM
       else
         (
diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
index 478cfa07..c9d30144 100644
--- a/ocamldoc/odoc_text_parser.mly
+++ b/ocamldoc/odoc_text_parser.mly
@@ -62,6 +62,8 @@ let print_DEBUG s = print_string s; print_newline ()
 %token ATT_REF
 %token MET_REF
 %token SEC_REF
+%token RECF_REF
+%token CONST_REF
 %token MOD_LIST_REF
 %token INDEX_LIST
 
@@ -110,6 +112,8 @@ ele_ref_kind:
 | ATT_REF { Some RK_attribute }
 | MET_REF { Some RK_method }
 | SEC_REF { Some (RK_section [])}
+| RECF_REF { Some RK_recfield }
+| CONST_REF { Some RK_const }
 ;
 
 text_element:
diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
index 9d19dc67..ee973a01 100644
--- a/ocamldoc/odoc_type.ml
+++ b/ocamldoc/odoc_type.ml
@@ -22,6 +22,7 @@ type private_flag = Asttypes.private_flag =
 type variant_constructor = {
     vc_name : string ;
     vc_args : Types.type_expr list ; (** arguments of the constructor *)
+    vc_ret : Types.type_expr option ;
     mutable vc_text : Odoc_types.text option ; (** optional user description *)
   }
 
diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml
index 53a1ca5f..85bac555 100644
--- a/ocamldoc/odoc_types.ml
+++ b/ocamldoc/odoc_types.ml
@@ -22,6 +22,8 @@ type ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element =
   | Raw of string
diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli
index d4affb50..124beba1 100644
--- a/ocamldoc/odoc_types.mli
+++ b/ocamldoc/odoc_types.mli
@@ -25,6 +25,8 @@ type ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element =
   | Raw of string (** Raw text. *)
diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
index a210f085..c8881ddf 100644
--- a/ocamldoc/odoc_value.ml
+++ b/ocamldoc/odoc_value.ml
@@ -77,13 +77,13 @@ let parameter_list_from_arrows typ =
     | Types.Tsubst texp ->
         iter texp
     | Types.Tpoly (texp, _) -> iter texp
-    | Types.Tvar
+    | Types.Tvar _
     | Types.Ttuple _
     | Types.Tconstr _
     | Types.Tobject _
     | Types.Tfield _
     | Types.Tnil
-    | Types.Tunivar
+    | Types.Tunivar _
     | Types.Tpackage _
     | Types.Tvariant _ ->
         []
diff --git a/ocamldoc/remove_DEBUG b/ocamldoc/remove_DEBUG
index 78b11e61..b8550e25 100755
--- a/ocamldoc/remove_DEBUG
+++ b/ocamldoc/remove_DEBUG
@@ -1,7 +1,7 @@
 #!/bin/sh
 
 #(***********************************************************************)
-#(*                            OCamldoc                                 *)
+#(*                             OCamldoc                                *)
 #(*                                                                     *)
 #(*            Damien Doligez, projet Moscova, INRIA Rocquencourt       *)
 #(*                                                                     *)
diff --git a/ocamldoc/runocamldoc b/ocamldoc/runocamldoc
index a71d705c..3aba7192 100644
--- a/ocamldoc/runocamldoc
+++ b/ocamldoc/runocamldoc
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#######################################################################
+#                                                                     #
+#                                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.               #
+#                                                                     #
+#######################################################################
+
 # $Id$
 
 case "$1" in
diff --git a/otherlibs/Makefile b/otherlibs/Makefile
index c5db1981..fba032df 100644
--- a/otherlibs/Makefile
+++ b/otherlibs/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt
index 32aca21c..ceab7f0c 100644
--- a/otherlibs/Makefile.nt
+++ b/otherlibs/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared
index 7e6780b3..08e9abb1 100644
--- a/otherlibs/Makefile.shared
+++ b/otherlibs/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/bigarray/.cvsignore b/otherlibs/bigarray/.cvsignore
deleted file mode 100644
index 52db225e..00000000
--- a/otherlibs/bigarray/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-*.o
-*.x
-so_locations
-*.so
-*.a
diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index c70f81a5..889328a3 100644
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -3,7 +3,7 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \
   ../../byterun/../config/s.h ../../byterun/mlvalues.h bigarray.h \
   ../../byterun/config.h ../../byterun/mlvalues.h ../../byterun/custom.h \
   ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \
-  ../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
 mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \
@@ -16,6 +16,6 @@ mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \
   ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \
   ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h \
   ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h
-bigarray.cmi:
-bigarray.cmo: bigarray.cmi
-bigarray.cmx: bigarray.cmi
+bigarray.cmi :
+bigarray.cmo : bigarray.cmi
+bigarray.cmx : bigarray.cmi
diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
index 38914ff3..83b31525 100644
--- a/otherlibs/bigarray/Makefile
+++ b/otherlibs/bigarray/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
index 78f3fc6b..e845ad62 100644
--- a/otherlibs/bigarray/Makefile.nt
+++ b/otherlibs/bigarray/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h
index 407a5377..f6552107 100644
--- a/otherlibs/bigarray/bigarray.h
+++ b/otherlibs/bigarray/bigarray.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -42,7 +42,7 @@ enum caml_ba_kind {
   CAML_BA_UINT16,              /* Unsigned 16-bit integers */
   CAML_BA_INT32,               /* Signed 32-bit integers */
   CAML_BA_INT64,               /* Signed 64-bit integers */
-  CAML_BA_CAML_INT,            /* Caml-style integers (signed 31 or 63 bits) */
+  CAML_BA_CAML_INT,            /* OCaml-style integers (signed 31 or 63 bits) */
   CAML_BA_NATIVE_INT,       /* Platform-native long integers (32 or 64 bits) */
   CAML_BA_COMPLEX32,           /* Single-precision complex */
   CAML_BA_COMPLEX64,           /* Double-precision complex */
@@ -56,8 +56,8 @@ enum caml_ba_layout {
 };
 
 enum caml_ba_managed {
-  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by Caml */
-  CAML_BA_MANAGED = 0x200,     /* Data is allocated by Caml */
+  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by OCaml */
+  CAML_BA_MANAGED = 0x200,     /* Data is allocated by OCaml */
   CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */
   CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */
 };
@@ -73,7 +73,12 @@ struct caml_ba_array {
   intnat num_dims;            /* Number of dimensions */
   intnat flags;  /* Kind of element array + memory layout + allocation status */
   struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  intnat dim[]  /*[num_dims]*/; /* Size in each dimension */
+#else
   intnat dim[1] /*[num_dims]*/; /* Size in each dimension */
+#endif
 };
 
 #define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v))
diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
index 09ae8bd1..b9f22b18 100644
--- a/otherlibs/bigarray/bigarray.ml
+++ b/otherlibs/bigarray/bigarray.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Manuel Serrano et Xavier Leroy, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -99,6 +99,8 @@ module Genarray = struct
                      = "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
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 module Array1 = struct
@@ -122,6 +124,8 @@ module Array1 = struct
     ba
   let map_file fd ?pos kind layout shared dim =
     Genarray.map_file fd ?pos kind layout shared [|dim|]
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 module Array2 = struct
@@ -161,6 +165,8 @@ module Array2 = struct
     ba
   let map_file fd ?pos kind layout shared dim1 dim2 =
     Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|]
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 module Array3 = struct
@@ -210,6 +216,8 @@ module Array3 = struct
     ba
   let map_file fd ?pos kind layout shared dim1 dim2 dim3 =
     Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|]
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
index a49923ae..73c27b57 100644
--- a/otherlibs/bigarray/bigarray.mli
+++ b/otherlibs/bigarray/bigarray.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,13 +18,13 @@
    This module implements multi-dimensional arrays of integers and
    floating-point numbers, thereafter referred to as ``big arrays''.
    The implementation allows efficient sharing of large numerical
-   arrays between Caml code and C or Fortran numerical libraries.
+   arrays between OCaml code and C or Fortran numerical libraries.
 
    Concerning the naming conventions, users of this module are encouraged
    to do [open Bigarray] in their source, then refer to array types and
    operations via short dot notation, e.g. [Array1.t] or [Array2.sub].
 
-   Big arrays support all the Caml ad-hoc polymorphic operations:
+   Big arrays support all the OCaml ad-hoc polymorphic operations:
    - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare});
    - hashing (module [Hash]);
    - and structured input-output ({!Pervasives.output_value}
@@ -47,7 +47,7 @@
    ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}),
 - 16-bit integers (signed or unsigned)
    ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}),
-- Caml integers (signed, 31 bits on 32-bit architectures,
+- OCaml integers (signed, 31 bits on 32-bit architectures,
    63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
 - 32-bit signed integer ({!Bigarray.int32_elt}),
 - 64-bit signed integers ({!Bigarray.int64_elt}),
@@ -72,20 +72,20 @@ type int64_elt
 type nativeint_elt
 
 type ('a, 'b) kind
-(** To each element kind is associated a Caml type, which is
-   the type of Caml values that can be stored in the big array
+(** To each element kind is associated an OCaml type, which is
+   the type of OCaml values that can be stored in the big array
    or read back from it.  This type is not necessarily the same
    as the type of the array elements proper: for instance,
    a big array whose elements are of kind [float32_elt] contains
    32-bit single precision floats, but reading or writing one of
-   its elements from Caml uses the Caml type [float], which is
+   its elements from OCaml uses the OCaml type [float], which is
    64-bit double precision floats.
 
    The abstract type [('a, 'b) kind] captures this association
-   of a Caml type ['a] for values read or written in the big array,
+   of an OCaml type ['a] for values read or written in the big array,
    and of an element kind ['b] which represents the actual contents
    of the big array.  The following predefined values of type
-   [kind] list all possible associations of Caml types with
+   [kind] list all possible associations of OCaml types with
    element kinds: *)
 
 val float32 : (float, float32_elt) kind
@@ -127,12 +127,12 @@ val nativeint : (nativeint, nativeint_elt) kind
 val char : (char, int8_unsigned_elt) kind
 (** As shown by the types of the values above,
    big arrays of kind [float32_elt] and [float64_elt] are
-   accessed using the Caml type [float].  Big arrays of complex kinds
-   [complex32_elt], [complex64_elt] are accessed with the Caml type
+   accessed using the OCaml type [float].  Big arrays of complex kinds
+   [complex32_elt], [complex64_elt] are accessed with the OCaml type
    {!Complex.t}.  Big arrays of
-   integer kinds are accessed using the smallest Caml integer
+   integer kinds are accessed using the smallest OCaml integer
    type large enough to represent the array elements:
-   [int] for 8- and 16-bit integer bigarrays, as well as Caml-integer
+   [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer
    bigarrays; [int32] for 32-bit integer bigarrays; [int64]
    for 64-bit integer bigarrays; and [nativeint] for
    platform-native integer bigarrays.  Finally, big arrays of
@@ -195,7 +195,7 @@ module Genarray :
 
      The three type parameters to [Genarray.t] identify the array element
      kind and layout, as follows:
-     - the first parameter, ['a], is the Caml type for accessing array
+     - the first parameter, ['a], is the OCaml type for accessing array
        elements ([float], [int], [int32], [int64], [nativeint]);
      - the second parameter, ['b], is the actual kind of array elements
        ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt],
@@ -206,7 +206,7 @@ module Genarray :
      For instance, [(float, float32_elt, fortran_layout) Genarray.t]
      is the type of generic big arrays containing 32-bit floats
      in Fortran layout; reads and writes in this array use the
-     Caml type [float]. *)
+     OCaml type [float]. *)
 
   external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
     = "caml_ba_create"
@@ -418,9 +418,35 @@ module Genarray :
      than the big array, only the initial portion of the file is
      mapped to the big array.  If the file is smaller than the big
      array, the file is automatically grown to the size of the big array.
-     This requires write permissions on [fd]. *)
+     This requires write permissions on [fd].
+
+     Array accesses are bounds-checked, but the bounds are determined by
+     the initial call to [map_file]. Therefore, you should make sure no
+     other process modifies the mapped file while you're accessing it,
+     or a SIGBUS signal may be raised. This happens, for instance, if the
+     file is shrinked. *)
+
+  val release: ('a, 'b, 'c) t -> unit
+  (** Release the resources associated with the given big array,
+     then set all of its dimensions to 0, causing subsequent accesses
+     to the big array to fail.  This releasing of resources is performed
+     automatically by the garbage collector when the big array is no longer
+     referenced by the program.  However, memory behavior of the program
+     can be improved by releasing the resources explicitly via
+     [Genarray.release] as soon as the big array is no longer useful.
+
+     If the big array was created with [Genarray.create], the memory
+     space occupied by its data is freed.  If the big array was
+     created with [Genarray.map_file], updates performed on the array
+     are flushed to the file (if the mapping is shared), then the
+     mapping is removed, freeing the corresponding virtual memory
+     space.  If several views on the big array data were created
+     using [Genarray.sub_*] or [Genarray.slice_*], data release occurs
+     when the last not-yet-released view is released.  Multiple calls
+     to [Genarray.release] on the same big array are safe: the second
+     and subsequent calls have no effect. *)
 
-  end
+end
 
 (** {6 One-dimensional arrays} *)
 
@@ -434,7 +460,7 @@ module Genarray :
 module Array1 : sig
   type ('a, 'b, 'c) t
   (** The type of one-dimensional big arrays whose elements have
-     Caml type ['a], representation kind ['b], and memory layout ['c]. *)
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
 
   val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
   (** [Array1.create kind layout dim] returns a new bigarray of
@@ -490,16 +516,20 @@ module Array1 : sig
   (** Memory mapping of a file as a one-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
+  val release: ('a, 'b, 'c) t -> unit
+  (** Explicit release of the resources associated with the big array.
+     See {!Bigarray.Genarray.release} for more details. *)
+
   external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
   (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
       Use with caution and only when the program logic guarantees that
-      the access is within bounds. *)
+      the access is within bounds and the big array has not been released. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_1"
   (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed.
       Use with caution and only when the program logic guarantees that
-      the access is within bounds. *)
+      the access is within bounds and the big array has not been released. *)
 
 end
 
@@ -513,7 +543,7 @@ module Array2 :
   sig
   type ('a, 'b, 'c) t
   (** The type of two-dimensional big arrays whose elements have
-     Caml type ['a], representation kind ['b], and memory layout ['c]. *)
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
 
   val create: ('a, 'b) kind ->  'c layout -> int -> int -> ('a, 'b, 'c) t
   (** [Array2.create kind layout dim1 dim2] returns a new bigarray of
@@ -595,15 +625,21 @@ module Array2 :
   (** Memory mapping of a file as a two-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
+  val release: ('a, 'b, 'c) t -> unit
+  (** Explicit release of the resources associated with the big array.
+     See {!Bigarray.Genarray.release} for more details. *)
+
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_2"
-  (** Like {!Bigarray.Array2.get}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array2.get}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_2"
-  (** Like {!Bigarray.Array2.set}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array2.set}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
 end
 
@@ -616,7 +652,7 @@ module Array3 :
   sig
   type ('a, 'b, 'c) t
   (** The type of three-dimensional big arrays whose elements have
-     Caml type ['a], representation kind ['b], and memory layout ['c]. *)
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
 
   val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
   (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of
@@ -723,15 +759,21 @@ module Array3 :
   (** Memory mapping of a file as a three-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
+  val release: ('a, 'b, 'c) t -> unit
+  (** Explicit release of the resources associated with the big array.
+     See {!Bigarray.Genarray.release} for more details. *)
+
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_3"
-  (** Like {!Bigarray.Array3.get}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array3.get}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_3"
-  (** Like {!Bigarray.Array3.set}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array3.set}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
 end
 
diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index f4033dec..4021b74a 100644
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -21,6 +21,7 @@
 #include "custom.h"
 #include "fail.h"
 #include "intext.h"
+#include "hash.h"
 #include "memory.h"
 #include "mlvalues.h"
 
@@ -75,7 +76,8 @@ static struct custom_operations caml_ba_ops = {
   caml_ba_compare,
   caml_ba_hash,
   caml_ba_serialize,
-  caml_ba_deserialize
+  caml_ba_deserialize,
+  custom_compare_ext_default
 };
 
 /* Multiplication of unsigned longs with overflow detection */
@@ -121,20 +123,20 @@ caml_ba_multov(uintnat a, uintnat b, int * overflow)
 
 /* Allocation of a big array */
 
-#define CAML_BA_MAX_MEMORY 256*1024*1024
-/* 256 Mb -- after allocating that much, it's probably worth speeding
+#define CAML_BA_MAX_MEMORY 1024*1024*1024
+/* 1 Gb -- after allocating that much, it's probably worth speeding
    up the major GC */
 
 /* [caml_ba_alloc] will allocate a new bigarray object in the heap.
    If [data] is NULL, the memory for the contents is also allocated
    (with [malloc]) by [caml_ba_alloc].
-   [data] cannot point into the Caml heap.
-   [dim] may point into an object in the Caml heap.
+   [data] cannot point into the OCaml heap.
+   [dim] may point into an object in the OCaml heap.
 */
 CAMLexport value
 caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
 {
-  uintnat num_elts, size;
+  uintnat num_elts, asize, size;
   int overflow, i;
   value res;
   struct caml_ba_array * b;
@@ -158,10 +160,13 @@ 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;
   }
-  res = caml_alloc_custom(&caml_ba_ops,
-                          sizeof(struct caml_ba_array)
-                          + (num_dims - 1) * sizeof(intnat),
-                          size, CAML_BA_MAX_MEMORY);
+  /* 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
+  res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY);
   b = Caml_ba_array_val(res);
   b->data = data;
   b->num_dims = num_dims;
@@ -181,6 +186,7 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
   int i;
   value res;
 
+  Assert(num_dims <= CAML_BA_MAX_NUM_DIMS);
   va_start(ap, data);
   for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
   va_end(ap);
@@ -188,7 +194,7 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
   return res;
 }
 
-/* Allocate a bigarray from Caml */
+/* Allocate a bigarray from OCaml */
 
 CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
 {
@@ -490,18 +496,19 @@ CAMLprim value caml_ba_layout(value vb)
   return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK);
 }
 
-/* Finalization of a big array */
+/* Finalization / release of a big array */
 
 static void caml_ba_finalize(value v)
 {
   struct caml_ba_array * b = Caml_ba_array_val(v);
+  intnat i;
 
   switch (b->flags & CAML_BA_MANAGED_MASK) {
   case CAML_BA_EXTERNAL:
     break;
   case CAML_BA_MANAGED:
     if (b->proxy == NULL) {
-      free(b->data);
+      free(b->data);            /* no op if b->data = NULL */
     } else {
       if (-- b->proxy->refcount == 0) {
         free(b->proxy->data);
@@ -520,6 +527,17 @@ static void caml_ba_finalize(value v)
     }
     break;
   }
+  /* Make sure that subsequent accesses to the bigarray fail (empty bounds)
+     and that subsequent calls to caml_ba_finalize do nothing. */
+  for (i = 0; i < b->num_dims; i++) b->dim[i] = 0;
+  b->data = NULL;
+  b->proxy = NULL;
+}
+
+CAMLprim value caml_ba_release(value v)
+{
+  caml_ba_finalize(v);
+  return Val_unit;
 }
 
 /* Comparison of two big arrays */
@@ -621,69 +639,85 @@ static int caml_ba_compare(value v1, value v2)
 static intnat caml_ba_hash(value v)
 {
   struct caml_ba_array * b = Caml_ba_array_val(v);
-  intnat num_elts, n, h;
+  intnat num_elts, n;
+  uint32 h, w;
   int i;
 
   num_elts = 1;
   for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
-  if (num_elts >= 50) num_elts = 50;
   h = 0;
 
-#define COMBINE(h,v) ((h << 4) + h + (v))
-
   switch (b->flags & CAML_BA_KIND_MASK) {
   case CAML_BA_SINT8:
   case CAML_BA_UINT8: {
     uint8 * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    if (num_elts > 256) num_elts = 256;
+    for (n = 0; n + 4 <= num_elts; n += 4, p += 4) {
+      w = p[0] | (p[1] << 8) | (p[2] << 16) | (p[3] << 24);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    w = 0;
+    switch (num_elts & 3) {
+    case 3: w  = p[2] << 16;    /* fallthrough */
+    case 2: w |= p[1] << 8;     /* fallthrough */
+    case 1: w |= p[0];
+            h = caml_hash_mix_uint32(h, w);
+    }
     break;
   }
   case CAML_BA_SINT16:
   case CAML_BA_UINT16: {
     uint16 * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    if (num_elts > 128) num_elts = 128;
+    for (n = 0; n + 2 <= num_elts; n += 2, p += 2) {
+      w = p[0] | (p[1] << 16);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    if ((num_elts & 1) != 0)
+      h = caml_hash_mix_uint32(h, p[0]);
     break;
   }
-  case CAML_BA_FLOAT32:
-  case CAML_BA_COMPLEX32:
   case CAML_BA_INT32:
-#ifndef ARCH_SIXTYFOUR
-  case CAML_BA_CAML_INT:
-  case CAML_BA_NATIVE_INT:
-#endif
   {
     uint32 * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p);
     break;
   }
-  case CAML_BA_FLOAT64:
-  case CAML_BA_COMPLEX64:
-  case CAML_BA_INT64:
-#ifdef ARCH_SIXTYFOUR
   case CAML_BA_CAML_INT:
   case CAML_BA_NATIVE_INT:
-#endif
-#ifdef ARCH_SIXTYFOUR
   {
-    uintnat * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    intnat * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_intnat(h, *p);
     break;
   }
-#else
+  case CAML_BA_INT64:
   {
-    uint32 * p = b->data;
-    for (n = 0; n < num_elts; n++) {
-#ifdef ARCH_BIG_ENDIAN
-      h = COMBINE(h, p[1]); h = COMBINE(h, p[0]); p += 2;
-#else
-      h = COMBINE(h, p[0]); h = COMBINE(h, p[1]); p += 2;
-#endif
-    }
+    int64 * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX32:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT32:
+  {
+    float * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_float(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX64:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT64:
+  {
+    double * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_double(h, *p);
     break;
   }
-#endif
   }
-#undef COMBINE
   return h;
 }
 
@@ -755,7 +789,7 @@ static void caml_ba_serialize(value v,
     caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
     break;
   }
-  /* Compute required size in Caml heap.  Assumes struct caml_ba_array
+  /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
      is exactly 4 + num_dims words */
   Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value));
   *wsize_32 = (4 + b->num_dims) * 4;
@@ -776,7 +810,7 @@ static void caml_ba_deserialize_longarray(void * dest, intnat num_elts)
 #else
   if (sixty)
     caml_deserialize_error("input_value: cannot read bigarray "
-                      "with 64-bit Caml ints");
+                      "with 64-bit OCaml ints");
   caml_deserialize_block_4(dest, num_elts);
 #endif
 }
@@ -887,7 +921,7 @@ CAMLprim value caml_ba_slice(value vb, value vind)
   sub_data =
     (char *) b->data +
     offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
-  /* Allocate a Caml bigarray to hold the result */
+  /* Allocate an OCaml bigarray to hold the result */
   res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
   /* Create or update proxy in case of managed bigarray */
   caml_ba_update_proxy(b, Caml_ba_array_val(res));
@@ -928,7 +962,7 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
   sub_data =
     (char *) b->data +
     ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
-  /* Allocate a Caml bigarray to hold the result */
+  /* Allocate an OCaml bigarray to hold the result */
   res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
   /* Doctor the changed dimension */
   Caml_ba_array_val(res)->dim[changed_dim] = len;
@@ -1062,7 +1096,7 @@ CAMLprim value caml_ba_reshape(value vb, value vdim)
   num_elts = 1;
   for (i = 0; i < num_dims; i++) {
     dim[i] = Long_val(Field(vdim, i));
-    if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL)
+    if (dim[i] < 0)
       caml_invalid_argument("Bigarray.reshape: negative dimension");
     num_elts *= dim[i];
   }
diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
index 6af03930..30294cc4 100644
--- a/otherlibs/bigarray/mmap_unix.c
+++ b/otherlibs/bigarray/mmap_unix.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -25,12 +25,14 @@
 
 extern int caml_ba_element_size[];  /* from bigarray_stubs.c */
 
+#include 
 #ifdef HAS_UNISTD
 #include 
 #endif
 #ifdef HAS_MMAP
 #include 
 #include 
+#include 
 #endif
 
 #if defined(HAS_MMAP)
@@ -39,15 +41,61 @@ extern int caml_ba_element_size[];  /* from bigarray_stubs.c */
 #define MAP_FAILED ((void *) -1)
 #endif
 
+/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */
+
+static int caml_grow_file(int fd, file_offset size)
+{
+  char c;
+  int p;
+
+  /* First use pwrite for growing - it is a conservative method, as it
+     can never happen that we shrink by accident
+   */
+#ifdef HAS_PWRITE
+  c = 0;
+  p = pwrite(fd, &c, 1, size - 1);
+#else
+
+  /* Emulate pwrite with lseek. This should only be necessary on ancient
+     systems nowadays
+   */
+  file_offset currpos;
+  currpos = lseek(fd, 0, SEEK_CUR);
+  if (currpos != -1) {
+    p = lseek(fd, size - 1, SEEK_SET);
+    if (p != -1) {
+      c = 0;
+      p = write(fd, &c, 1);
+      if (p != -1) 
+        p = lseek(fd, currpos, SEEK_SET);
+    }
+  }
+  else p=-1;
+#endif
+#ifdef HAS_TRUNCATE
+  if (p == -1 && errno == ESPIPE) {
+    /* Plan B. Check if at least ftruncate is possible. There are
+       some non-seekable descriptor types that do not support pwrite
+       but ftruncate, like shared memory. We never get into this case
+       for real files, so there is no danger of truncating persistent
+       data by accident
+     */
+    p = ftruncate(fd, size);
+  }
+#endif
+  return p;
+}
+
+
 CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
                                 value vshared, value vdim, value vstart)
 {
   int fd, flags, major_dim, shared;
   intnat num_dims, i;
   intnat dim[CAML_BA_MAX_NUM_DIMS];
-  file_offset currpos, startpos, file_size, data_size;
+  file_offset startpos, file_size, data_size;
+  struct stat st;
   uintnat array_size, page, delta;
-  char c;
   void * addr;
 
   fd = Int_val(vfd);
@@ -55,7 +103,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   startpos = File_offset_val(vstart);
   num_dims = Wosize_val(vdim);
   major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
-  /* Extract dimensions from Caml array */
+  /* Extract dimensions from OCaml array */
   num_dims = Wosize_val(vdim);
   if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
     caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
@@ -65,18 +113,15 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
     if (dim[i] < 0)
       caml_invalid_argument("Bigarray.create: negative dimension");
   }
-  /* Determine file size */
+  /* Determine file size. We avoid lseek here because it is fragile,
+     and because some mappable file types do not support it
+   */
   caml_enter_blocking_section();
-  currpos = lseek(fd, 0, SEEK_CUR);
-  if (currpos == -1) {
-    caml_leave_blocking_section();
-    caml_sys_error(NO_ARG);
-  }
-  file_size = lseek(fd, 0, SEEK_END);
-  if (file_size == -1) {
+  if (fstat(fd, &st) == -1) {
     caml_leave_blocking_section();
     caml_sys_error(NO_ARG);
   }
+  file_size = st.st_size;
   /* Determine array size in bytes (or size of array without the major
      dimension if that dimension wasn't specified) */
   array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
@@ -99,37 +144,33 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   } else {
     /* Check that file is large enough, and grow it otherwise */
     if (file_size < startpos + array_size) {
-      if (lseek(fd, startpos + array_size - 1, SEEK_SET) == -1) {
-        caml_leave_blocking_section();
-        caml_sys_error(NO_ARG);
-      }
-      c = 0;
-      if (write(fd, &c, 1) != 1) {
+      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
         caml_leave_blocking_section();
         caml_sys_error(NO_ARG);
       }
     }
   }
-  /* Restore original file position */
-  lseek(fd, currpos, SEEK_SET);
   /* Determine offset so that the mapping starts at the given file pos */
   page = getpagesize();
-  delta = (uintnat) (startpos % page);
+  delta = (uintnat) startpos % page;
   /* Do the mmap */
   shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
-  addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
-              shared, fd, startpos - delta);
+  if (array_size > 0)
+    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
+                shared, fd, startpos - delta);
+  else
+    addr = NULL;                /* PR#5463 - mmap fails on empty region */
   caml_leave_blocking_section();
   if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG);
   addr = (void *) ((uintnat) addr + delta);
-  /* Build and return the Caml bigarray */
+  /* Build and return the OCaml bigarray */
   return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
 }
 
 #else
 
-value caml_ba_map_file(value vfd, value vkind, value vlayout,
-                       value vshared, value vdim, value vpos)
+CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
+                                value vshared, value vdim, value vpos)
 {
   caml_invalid_argument("Bigarray.map_file: not supported");
   return Val_unit;
@@ -148,6 +189,12 @@ void caml_ba_unmap_file(void * addr, uintnat len)
 #if defined(HAS_MMAP)
   uintnat page = getpagesize();
   uintnat delta = (uintnat) addr % page;
-  munmap((void *)((uintnat)addr - delta), len + delta);
+  if (len == 0) return;         /* PR#5463 */
+  addr = (void *)((uintnat)addr - delta);
+  len  = len + delta;
+#if defined(_POSIX_SYNCHRONIZED_IO)
+  msync(addr, len, MS_ASYNC);   /* PR#3571 */
+#endif
+  munmap(addr, len);
 #endif
 }
diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c
index 9be9e18e..ded2270e 100644
--- a/otherlibs/bigarray/mmap_win32.c
+++ b/otherlibs/bigarray/mmap_win32.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -62,7 +62,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   startpos = Int64_val(vstart);
   num_dims = Wosize_val(vdim);
   major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
-  /* Extract dimensions from Caml array */
+  /* Extract dimensions from OCaml array */
   num_dims = Wosize_val(vdim);
   if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
     caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
@@ -117,7 +117,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   addr = (void *) ((uintnat) addr + delta);
   /* Close the file mapping */
   CloseHandle(fmap);
-  /* Build and return the Caml bigarray */
+  /* Build and return the OCaml bigarray */
   return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
 }
 
diff --git a/otherlibs/dbm/.cvsignore b/otherlibs/dbm/.cvsignore
deleted file mode 100644
index 29fea472..00000000
--- a/otherlibs/dbm/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-so_locations
-*.so
-*.a
diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend
deleted file mode 100644
index 4e5750fa..00000000
--- a/otherlibs/dbm/.depend
+++ /dev/null
@@ -1,3 +0,0 @@
-dbm.cmi:
-dbm.cmo: dbm.cmi
-dbm.cmx: dbm.cmi
diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile
deleted file mode 100644
index 099327d6..00000000
--- a/otherlibs/dbm/Makefile
+++ /dev/null
@@ -1,32 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../../LICENSE.   #
-#                                                                       #
-#########################################################################
-
-# $Id$
-
-# Makefile for the ndbm library
-
-LIBNAME=dbm
-CLIBNAME=mldbm
-CAMLOBJS=dbm.cmo
-COBJS=cldbm.o
-EXTRACFLAGS=$(DBM_INCLUDES)
-LINKOPTS=$(DBM_LINK)
-LDOPTS=-ldopt "$(DBM_LINK)"
-
-include ../Makefile
-
-
-depend:
-	../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/dbm/cldbm.c b/otherlibs/dbm/cldbm.c
deleted file mode 100644
index 0d6cb362..00000000
--- a/otherlibs/dbm/cldbm.c
+++ /dev/null
@@ -1,166 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Francois Rouaix, 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.  */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include 
-#include 
-#include 
-#include 
-#include 
-#include 
-#include 
-
-#ifdef DBM_USES_GDBM_NDBM
-#include 
-#else
-#include 
-#endif
-
-/* Quite close to sys_open_flags, but we need RDWR */
-static int dbm_open_flags[] = {
-  O_RDONLY, O_WRONLY, O_RDWR, O_CREAT
-};
-
-static void raise_dbm (char *errmsg) Noreturn;
-
-static void raise_dbm(char *errmsg)
-{
-  static value * dbm_exn = NULL;
-  if (dbm_exn == NULL)
-    dbm_exn = caml_named_value("dbmerror");
-  raise_with_string(*dbm_exn, errmsg);
-}
-
-#define DBM_val(v) *((DBM **) &Field(v, 0))
-
-static value alloc_dbm(DBM * db)
-{
-  value res = alloc_small(1, Abstract_tag);
-  DBM_val(res) = db;
-  return res;
-}
-
-static DBM * extract_dbm(value vdb)
-{
-  if (DBM_val(vdb) == NULL) raise_dbm("DBM has been closed");
-  return DBM_val(vdb);
-}
-
-/* Dbm.open : string -> Sys.open_flag list -> int -> t */
-value caml_dbm_open(value vfile, value vflags, value vmode) /* ML */
-{
-  char *file = String_val(vfile);
-  int flags = convert_flag_list(vflags, dbm_open_flags);
-  int mode = Int_val(vmode);
-  DBM *db = dbm_open(file,flags,mode);
-
-  if (db == NULL)
-    raise_dbm("Can't open file");
-  else
-    return (alloc_dbm(db));
-}
-
-/* Dbm.close: t -> unit */
-value caml_dbm_close(value vdb)       /* ML */
-{
-  dbm_close(extract_dbm(vdb));
-  DBM_val(vdb) = NULL;
-  return Val_unit;
-}
-
-/* Dbm.fetch: t -> string -> string */
-value caml_dbm_fetch(value vdb, value vkey)  /* ML */
-{
-  datum key,answer;
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-  answer = dbm_fetch(extract_dbm(vdb), key);
-  if (answer.dptr) {
-    value res = alloc_string(answer.dsize);
-    memmove (String_val (res), answer.dptr, answer.dsize);
-    return res;
-  }
-  else raise_not_found();
-}
-
-value caml_dbm_insert(value vdb, value vkey, value vcontent) /* ML */
-{
-  datum key, content;
-
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-  content.dptr = String_val(vcontent);
-  content.dsize = string_length(vcontent);
-
-  switch(dbm_store(extract_dbm(vdb), key, content, DBM_INSERT)) {
-  case 0:
-    return Val_unit;
-  case 1:                       /* DBM_INSERT and already existing */
-    raise_dbm("Entry already exists");
-  default:
-    raise_dbm("dbm_store failed");
-  }
-}
-
-value caml_dbm_replace(value vdb, value vkey, value vcontent) /* ML */
-{
-  datum key, content;
-
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-  content.dptr = String_val(vcontent);
-  content.dsize = string_length(vcontent);
-
-  switch(dbm_store(extract_dbm(vdb), key, content, DBM_REPLACE)) {
-  case 0:
-    return Val_unit;
-  default:
-    raise_dbm("dbm_store failed");
-  }
-}
-
-value caml_dbm_delete(value vdb, value vkey)         /* ML */
-{
-  datum key;
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-
-  if (dbm_delete(extract_dbm(vdb), key) < 0)
-    raise_dbm("dbm_delete");
-  else return Val_unit;
-}
-
-value caml_dbm_firstkey(value vdb)            /* ML */
-{
-  datum key = dbm_firstkey(extract_dbm(vdb));
-
-  if (key.dptr) {
-    value res = alloc_string(key.dsize);
-    memmove (String_val (res), key.dptr, key.dsize);
-    return res;
-  }
-  else raise_not_found();
-}
-
-value caml_dbm_nextkey(value vdb)             /* ML */
-{
-  datum key = dbm_nextkey(extract_dbm(vdb));
-
-  if (key.dptr) {
-    value res = alloc_string(key.dsize);
-    memmove (String_val (res), key.dptr, key.dsize);
-    return res;
-  }
-  else raise_not_found();
-}
diff --git a/otherlibs/dbm/dbm.ml b/otherlibs/dbm/dbm.ml
deleted file mode 100644
index f31d2993..00000000
--- a/otherlibs/dbm/dbm.ml
+++ /dev/null
@@ -1,58 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*          Francois Rouaix, 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.  *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type t
-
-type open_flag =
-   Dbm_rdonly | Dbm_wronly | Dbm_rdwr | Dbm_create
-
-type dbm_flag =
-   DBM_INSERT
- | DBM_REPLACE
-
-exception Dbm_error of string
-
-external raw_opendbm : string -> open_flag list -> int -> t
-              = "caml_dbm_open"
-
-let opendbm file flags mode =
-  try
-    raw_opendbm file flags mode
-  with Dbm_error msg ->
-    raise(Dbm_error("Can't open file " ^ file))
-
- (* By exporting opendbm as val, we are sure to link in this
-    file (we must register the exception). Since t is abstract, programs
-    have to call it in order to do anything *)
-
-external close : t -> unit = "caml_dbm_close"
-external find : t -> string -> string = "caml_dbm_fetch"
-external add : t -> string -> string -> unit = "caml_dbm_insert"
-external replace : t -> string -> string -> unit = "caml_dbm_replace"
-external remove : t -> string -> unit = "caml_dbm_delete"
-external firstkey : t -> string = "caml_dbm_firstkey"
-external nextkey : t -> string = "caml_dbm_nextkey"
-
-let _ = Callback.register_exception "dbmerror" (Dbm_error "")
-
-(* Usual iterator *)
-let iter f t =
-  let rec walk = function
-      None -> ()
-    | Some k ->
-        f k (find t k);
-        walk (try Some(nextkey t) with Not_found -> None)
-  in
-  walk (try Some(firstkey t) with Not_found -> None)
diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli
deleted file mode 100644
index f9924427..00000000
--- a/otherlibs/dbm/dbm.mli
+++ /dev/null
@@ -1,79 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*          Francois Rouaix, 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.  *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Interface to the NDBM database. *)
-
-type t
-(** The type of file descriptors opened on NDBM databases. *)
-
-
-type open_flag =
-    Dbm_rdonly
-  | Dbm_wronly
-  | Dbm_rdwr
-  | Dbm_create
-(** Flags for opening a database (see {!Dbm.opendbm}). *)
-
-
-exception Dbm_error of string
-(** Raised by the following functions when an error is encountered. *)
-
-val opendbm : string -> open_flag list -> int -> t
-(** Open a descriptor on an NDBM database. The first argument is
-   the name of the database (without the [.dir] and [.pag] suffixes).
-   The second argument is a list of flags: [Dbm_rdonly] opens
-   the database for reading only, [Dbm_wronly] for writing only,
-   [Dbm_rdwr] for reading and writing; [Dbm_create] causes the
-   database to be created if it does not already exist.
-   The third argument is the permissions to give to the database
-   files, if the database is created. *)
-
-external close : t -> unit = "caml_dbm_close"
-(** Close the given descriptor. *)
-
-external find : t -> string -> string = "caml_dbm_fetch"
-(** [find db key] returns the data associated with the given
-   [key] in the database opened for the descriptor [db].
-   Raise [Not_found] if the [key] has no associated data. *)
-
-external add : t -> string -> string -> unit = "caml_dbm_insert"
-(** [add db key data] inserts the pair ([key], [data]) in
-   the database [db]. If the database already contains data
-   associated with [key], raise [Dbm_error "Entry already exists"]. *)
-
-external replace : t -> string -> string -> unit = "caml_dbm_replace"
-(** [replace db key data] inserts the pair ([key], [data]) in
-   the database [db]. If the database already contains data
-   associated with [key], that data is discarded and silently
-   replaced by the new [data]. *)
-
-external remove : t -> string -> unit = "caml_dbm_delete"
-(** [remove db key data] removes the data associated with [key]
-   in [db]. If [key] has no associated data, raise
-   [Dbm_error "dbm_delete"]. *)
-
-external firstkey : t -> string = "caml_dbm_firstkey"
-(** See {!Dbm.nextkey}.*)
-
-external nextkey : t -> string = "caml_dbm_nextkey"
-(** Enumerate all keys in the given database, in an unspecified order.
-   [firstkey db] returns the first key, and repeated calls
-   to [nextkey db] return the remaining keys. [Not_found] is raised
-   when all keys have been enumerated. *)
-
-val iter : (string -> string -> 'a) -> t -> unit
-(** [iter f db] applies [f] to each ([key], [data]) pair in
-   the database [db]. [f] receives [key] as first argument
-   and [data] as second argument. *)
diff --git a/otherlibs/dbm/libmldbm.clib b/otherlibs/dbm/libmldbm.clib
deleted file mode 100644
index 3a63b870..00000000
--- a/otherlibs/dbm/libmldbm.clib
+++ /dev/null
@@ -1 +0,0 @@
-cldbm.o
diff --git a/otherlibs/dynlink/.cvsignore b/otherlibs/dynlink/.cvsignore
deleted file mode 100644
index 29b3102d..00000000
--- a/otherlibs/dynlink/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-extract_crc
-*.a
diff --git a/otherlibs/dynlink/.ignore b/otherlibs/dynlink/.ignore
new file mode 100644
index 00000000..5ea9775e
--- /dev/null
+++ b/otherlibs/dynlink/.ignore
@@ -0,0 +1 @@
+extract_crc
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 3da485f4..e6a63295 100644
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,7 +28,7 @@ COMPILEROBJS=\
   ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \
   ../../utils/tbl.cmo ../../utils/consistbl.cmo \
   ../../utils/terminfo.cmo ../../utils/warnings.cmo \
-  ../../parsing/asttypes.cmi ../../parsing/linenum.cmo \
+  ../../parsing/asttypes.cmi \
   ../../parsing/location.cmo ../../parsing/longident.cmo \
   ../../typing/ident.cmo ../../typing/path.cmo \
   ../../typing/primitive.cmo ../../typing/types.cmo \
diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt
index 3d8b84b7..31ee136d 100644
--- a/otherlibs/dynlink/Makefile.nt
+++ b/otherlibs/dynlink/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index 0d324a85..7415ae6c 100644
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -121,8 +121,7 @@ let digest_interface unit loadpath =
       raise (Error(File_not_found shortname)) in
   let ic = open_in_bin filename in
   try
-    let buffer = String.create (String.length Config.cmi_magic_number) in
-    really_input ic buffer 0 (String.length Config.cmi_magic_number);
+    let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in
     if buffer <> Config.cmi_magic_number then begin
       close_in ic;
       raise(Error(Corrupted_interface filename))
@@ -159,7 +158,10 @@ let check_unsafe_module cu =
 
 (* Load in-core and execute a bytecode object file *)
 
-let load_compunit ic file_name compunit =
+external register_code_fragment: string -> int -> string -> unit
+                               = "caml_register_code_fragment"
+
+let load_compunit ic file_name file_digest compunit =
   check_consistency file_name compunit;
   check_unsafe_module compunit;
   seek_in ic compunit.cu_pos;
@@ -188,6 +190,11 @@ let load_compunit ic file_name compunit =
       | _ -> assert false in
     raise(Error(Linking_error (file_name, new_error)))
   end;
+  (* PR#5215: identify this code fragment by 
+     digest of file contents + unit name.
+     Unit name is needed for .cma files, which produce several code fragments.*)
+  let digest = Digest.string (file_digest ^ compunit.cu_name) in
+  register_code_fragment code code_size digest;
   begin try
     ignore((Meta.reify_bytecode code code_size) ())
   with exn ->
@@ -199,16 +206,18 @@ let loadfile file_name =
   init();
   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;
   try
-    let buffer = String.create (String.length Config.cmo_magic_number) in
-    begin
-      try really_input ic buffer 0 (String.length Config.cmo_magic_number)
-      with End_of_file -> raise(Error(Not_a_bytecode_file file_name))
-    end;
+    let buffer =
+      try Misc.input_bytes ic (String.length Config.cmo_magic_number)
+      with End_of_file -> raise (Error (Not_a_bytecode_file file_name))
+    in
     if buffer = Config.cmo_magic_number then begin
       let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
       seek_in ic compunit_pos;
-      load_compunit ic file_name (input_value ic : compilation_unit)
+      let cu = (input_value ic : compilation_unit) in
+      load_compunit ic file_name file_digest cu
     end else
     if buffer = Config.cma_magic_number then begin
       let toc_pos = input_binary_int ic in  (* Go to table of contents *)
@@ -220,7 +229,7 @@ let loadfile file_name =
       with Failure reason ->
         raise(Error(Cannot_open_dll reason))
       end;
-      List.iter (load_compunit ic file_name) lib.lib_units
+      List.iter (load_compunit ic file_name file_digest) lib.lib_units
     end else
       raise(Error(Not_a_bytecode_file file_name));
     close_in ic
diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
index 7cca68c5..849f1e14 100644
--- a/otherlibs/dynlink/dynlink.mli
+++ b/otherlibs/dynlink/dynlink.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -98,7 +98,7 @@ val add_available_units : (string * Digest.t) list -> unit
     for each unit. This way, the [.cmi] interface files need not be
     available at run-time. The digests can be extracted from [.cmi]
     files using the [extract_crc] program installed in the
-    Objective Caml standard library directory. *)
+    OCaml standard library directory. *)
 
 val clear_available_units : unit -> unit
 (** Empty the list of compilation units accessible to dynamically-linked
diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml
index e7d9139b..672ca6ea 100644
--- a/otherlibs/dynlink/extract_crc.ml
+++ b/otherlibs/dynlink/extract_crc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index 6ab9b985..d980a7b9 100644
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/graph/.cvsignore b/otherlibs/graph/.cvsignore
deleted file mode 100644
index 29fea472..00000000
--- a/otherlibs/graph/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-so_locations
-*.so
-*.a
diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index 54df0691..f72f26bd 100644
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -1,106 +1,106 @@
-color.o: color.c libgraph.h \
-  \
-  \
-  \
+color.o: color.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.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 \
-  \
-  \
-  \
+  /opt/local/include/X11/Xatom.h
+draw.o: draw.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h
-dump_img.o: dump_img.c libgraph.h \
-  \
-  \
-  \
+dump_img.o: dump_img.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h image.h \
   ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
-events.o: events.c libgraph.h \
-  \
-  \
-  \
+events.o: events.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/signals.h
-fill.o: fill.c libgraph.h \
-  \
-  \
-  \
+fill.o: fill.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h
-image.o: image.c libgraph.h \
-  \
-  \
-  \
+image.o: image.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h image.h \
   ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h
-make_img.o: make_img.c libgraph.h \
-  \
-  \
-  \
+make_img.o: make_img.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h image.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/mlvalues.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
-open.o: open.c libgraph.h \
-  \
-  \
-  \
+open.o: open.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/callback.h ../../byterun/fail.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h
-point_col.o: point_col.c libgraph.h \
-  \
-  \
-  \
+point_col.o: point_col.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h
-sound.o: sound.c libgraph.h \
-  \
-  \
-  \
+sound.o: sound.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h
-subwindow.o: subwindow.c libgraph.h \
-  \
-  \
-  \
+subwindow.o: subwindow.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h
-text.o: text.c libgraph.h \
-  \
-  \
-  \
+text.o: text.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h
-graphics.cmi:
-graphicsX11.cmi:
-graphics.cmo: graphics.cmi
-graphics.cmx: graphics.cmi
-graphicsX11.cmo: graphics.cmi graphicsX11.cmi
-graphicsX11.cmx: graphics.cmx graphicsX11.cmi
+graphics.cmi :
+graphicsX11.cmi :
+graphics.cmo : graphics.cmi
+graphics.cmx : graphics.cmi
+graphicsX11.cmo : graphics.cmi graphicsX11.cmi
+graphicsX11.cmx : graphics.cmx graphicsX11.cmi
diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index 2be98446..19c4612e 100644
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c
index 0dc29670..bdd8b5e2 100644
--- a/otherlibs/graph/color.c
+++ b/otherlibs/graph/color.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c
index 35a4ae17..0419c627 100644
--- a/otherlibs/graph/draw.c
+++ b/otherlibs/graph/draw.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c
index 8c82c21b..66185d87 100644
--- a/otherlibs/graph/dump_img.c
+++ b/otherlibs/graph/dump_img.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
index d9563a39..50893105 100644
--- a/otherlibs/graph/events.c
+++ b/otherlibs/graph/events.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c
index 0430c14a..bb1a60e7 100644
--- a/otherlibs/graph/fill.c
+++ b/otherlibs/graph/fill.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml
index 96a24716..a9dd5114 100644
--- a/otherlibs/graph/graphics.ml
+++ b/otherlibs/graph/graphics.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli
index 23d61a39..10074cb7 100644
--- a/otherlibs/graph/graphics.mli
+++ b/otherlibs/graph/graphics.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml
index 85f5a436..4b70d29b 100644
--- a/otherlibs/graph/graphicsX11.ml
+++ b/otherlibs/graph/graphicsX11.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli
index 11182537..0210d967 100644
--- a/otherlibs/graph/graphicsX11.mli
+++ b/otherlibs/graph/graphicsX11.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -18,12 +18,12 @@
 type window_id = string
 
 val window_id : unit -> window_id
-(** Return the unique identifier of the Caml graphics window.
+(** Return the unique identifier of the OCaml graphics window.
    The returned string is an unsigned 32 bits integer
    in decimal form. *)
 
 val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id
-(** Create a sub-window of the current Caml graphics window
+(** Create a sub-window of the current OCaml graphics window
    and return its identifier. *)
 
 val close_subwindow : window_id -> unit
diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c
index 501398b3..c610d96b 100644
--- a/otherlibs/graph/image.c
+++ b/otherlibs/graph/image.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -30,7 +30,8 @@ static struct custom_operations image_ops = {
   custom_compare_default,
   custom_hash_default,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 #define Max_image_mem 2000000
diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h
index 539cf9f8..76d319e0 100644
--- a/otherlibs/graph/image.h
+++ b/otherlibs/graph/image.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
index d2df1c1a..c8192e05 100644
--- a/otherlibs/graph/libgraph.h
+++ b/otherlibs/graph/libgraph.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -55,7 +55,7 @@ extern int caml_gr_bits_per_pixel;
 #define DEFAULT_SCREEN_WIDTH 600
 #define DEFAULT_SCREEN_HEIGHT 450
 #define BORDER_WIDTH 2
-#define DEFAULT_WINDOW_NAME "Caml graphics"
+#define DEFAULT_WINDOW_NAME "OCaml graphics"
 #define DEFAULT_SELECTED_EVENTS \
             (ExposureMask | KeyPressMask | StructureNotifyMask)
 #define DEFAULT_FONT "fixed"
diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c
index 325e6698..08628804 100644
--- a/otherlibs/graph/make_img.c
+++ b/otherlibs/graph/make_img.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
index 82a4c0fb..1f7da5ba 100644
--- a/otherlibs/graph/open.c
+++ b/otherlibs/graph/open.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c
index 473dae7d..2149aa8e 100644
--- a/otherlibs/graph/point_col.c
+++ b/otherlibs/graph/point_col.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c
index dc75b7ed..cba7a909 100644
--- a/otherlibs/graph/sound.c
+++ b/otherlibs/graph/sound.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c
index 642e28c4..08882569 100644
--- a/otherlibs/graph/subwindow.c
+++ b/otherlibs/graph/subwindow.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*              Jun Furuse, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
index f4d980ae..6743e864 100644
--- a/otherlibs/graph/text.c
+++ b/otherlibs/graph/text.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/labltk/.cvsignore b/otherlibs/labltk/.cvsignore
deleted file mode 100644
index f58b0734..00000000
--- a/otherlibs/labltk/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-labltklink
-labltkopt
-Makefile.config
-config.status
diff --git a/otherlibs/labltk/.ignore b/otherlibs/labltk/.ignore
new file mode 100644
index 00000000..f58b0734
--- /dev/null
+++ b/otherlibs/labltk/.ignore
@@ -0,0 +1,4 @@
+labltklink
+labltkopt
+Makefile.config
+config.status
diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile
index 8c3b823c..8b7209b1 100644
--- a/otherlibs/labltk/Makefile
+++ b/otherlibs/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 1999 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.          #
+#                                                                     #
+#######################################################################
+
 # Top Makefile for mlTk
 
 SUBDIRS=compiler support lib jpf frx examples_labltk \
diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt
index f1fd56ed..651540f3 100644
--- a/otherlibs/labltk/Makefile.nt
+++ b/otherlibs/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 2000 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.          #
+#                                                                     #
+#######################################################################
+
 # Top Makefile for LablTk
 
 include ../../config/Makefile
diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README
index b556d2b3..6815b666 100644
--- a/otherlibs/labltk/README
+++ b/otherlibs/labltk/README
@@ -1,6 +1,6 @@
 INTRODUCTION
 ============
-mlTk is a library for interfacing Objective Caml with the scripting
+mlTk is a library for interfacing OCaml with the scripting
 language Tcl/Tk (all versions since 8.0.3, but no betas).
 
 In addition to the basic interface with Tcl/Tk, this package contains
@@ -13,11 +13,11 @@ In addition to the basic interface with Tcl/Tk, this package contains
 
 mlTk = CamlTk + LablTk
 ======================
-There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk.
+There existed two parallel Tcl/Tk interfaces for OCaml, CamlTk and LablTk.
 
 CamlTk uses classical features only, therefore it is easy to understand for
-the beginners of ML. It makes many conservative O'Caml gurus also happy.
-LablTk, on the other hand, uses rather newer features of O'Caml, the labeled
+the beginners of ML. It makes many conservative OCaml gurus also happy.
+LablTk, on the other hand, uses rather newer features of OCaml, the labeled
 optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk
 script flavor, but provides more powerful typing than CamlTk at the same time
 (i.e. less run time type checking of widgets).
@@ -31,7 +31,7 @@ just with little fixes.
 REQUIREMENTS
 ============
 You must have already installed
- * Objective Caml source, version 3.04+8 or later
+ * OCaml source, version 3.04+8 or later
 
  * Tcl/Tk 8.0.3 or later
     http://www.scriptics.com/ or various mirrors
@@ -44,9 +44,9 @@ OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin).
 INSTALLATION
 ============
 
-0. Check-out the O'Caml CVS source code tree.
+0. Check-out the OCaml CVS source code tree.
 
-1. Compile O'Caml (= make world). If you want, also make opt.
+1. Compile OCaml (= make world). If you want, also make opt.
 
 2. Untar this mlTk distribution in the otherlibs directory, just like
    the labltk source tree.
@@ -55,9 +55,9 @@ INSTALLATION
 
 4. To install the library, make install (and make installopt)
 
-To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser
-requires some modules of O'Caml. If you are not interested in camlbrowser,
-you can compile mlTk without the O'Caml source tree, but you have to modify
+To compile mlTk, you need the OCaml source tree, since mltk/camlbrowser
+requires some modules of OCaml. If you are not interested in camlbrowser,
+you can compile mlTk without the OCaml source tree, but you have to modify
 support/Makefile.common.
 
 
diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src
index abf015a2..e6626827 100644
--- a/otherlibs/labltk/Widgets.src
+++ b/otherlibs/labltk/Widgets.src
@@ -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.          *)
+%(*                                                                     *)
+%(***********************************************************************)
+
 %%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%%
 type Widget external
 
diff --git a/otherlibs/labltk/browser/.cvsignore b/otherlibs/labltk/browser/.cvsignore
deleted file mode 100644
index 8ced21de..00000000
--- a/otherlibs/labltk/browser/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-ocamlbrowser
-dummy.mli
diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend
index 4438a1dd..4a0040b3 100644
--- a/otherlibs/labltk/browser/.depend
+++ b/otherlibs/labltk/browser/.depend
@@ -1,66 +1,101 @@
-editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \
+editor.cmo : viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \
     searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \
     jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \
     fileselect.cmi editor.cmi
-editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \
+editor.cmx : viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \
     searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \
     jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \
     fileselect.cmx editor.cmi
-fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \
-    jg_entry.cmo jg_box.cmo fileselect.cmi
-fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \
-    jg_entry.cmx jg_box.cmx fileselect.cmi
-jg_bind.cmo: jg_bind.cmi
-jg_bind.cmx: jg_bind.cmi
-jg_box.cmo: jg_completion.cmi jg_bind.cmi
-jg_box.cmx: jg_completion.cmx jg_bind.cmx
-jg_completion.cmo: jg_completion.cmi
-jg_completion.cmx: jg_completion.cmi
-jg_config.cmo: jg_tk.cmo jg_config.cmi
-jg_config.cmx: jg_tk.cmx jg_config.cmi
-jg_entry.cmo: jg_bind.cmi
-jg_entry.cmx: jg_bind.cmx
-jg_memo.cmo: jg_memo.cmi
-jg_memo.cmx: jg_memo.cmi
-jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
+fileselect.cmo : useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo \
+    jg_memo.cmi jg_entry.cmo jg_box.cmo fileselect.cmi
+fileselect.cmx : useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx \
+    jg_memo.cmx jg_entry.cmx jg_box.cmx fileselect.cmi
+help.cmo :
+help.cmx :
+jg_bind.cmo : jg_bind.cmi
+jg_bind.cmx : jg_bind.cmi
+jg_box.cmo : jg_completion.cmi jg_bind.cmi
+jg_box.cmx : jg_completion.cmx jg_bind.cmx
+jg_button.cmo :
+jg_button.cmx :
+jg_completion.cmo : jg_completion.cmi
+jg_completion.cmx : jg_completion.cmi
+jg_config.cmo : jg_tk.cmo jg_config.cmi
+jg_config.cmx : jg_tk.cmx jg_config.cmi
+jg_entry.cmo : jg_bind.cmi
+jg_entry.cmx : jg_bind.cmx
+jg_memo.cmo : jg_memo.cmi
+jg_memo.cmx : jg_memo.cmi
+jg_menu.cmo :
+jg_menu.cmx :
+jg_message.cmo : jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
     jg_message.cmi
-jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
+jg_message.cmx : jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
     jg_message.cmi
-jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi
-jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi
-jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi
-jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi
-lexical.cmo: jg_tk.cmo lexical.cmi
-lexical.cmx: jg_tk.cmx lexical.cmi
-main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \
+jg_multibox.cmo : jg_completion.cmi jg_bind.cmi jg_multibox.cmi
+jg_multibox.cmx : jg_completion.cmx jg_bind.cmx jg_multibox.cmi
+jg_text.cmo : jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi \
+    jg_text.cmi
+jg_text.cmx : jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx \
+    jg_text.cmi
+jg_tk.cmo :
+jg_tk.cmx :
+jg_toplevel.cmo :
+jg_toplevel.cmx :
+lexical.cmo : jg_tk.cmo lexical.cmi
+lexical.cmx : jg_tk.cmx lexical.cmi
+list2.cmo :
+list2.cmx :
+main.cmo : viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \
     editor.cmi
-main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \
+main.cmx : viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \
     editor.cmx
-searchid.cmo: list2.cmo searchid.cmi
-searchid.cmx: list2.cmx searchid.cmi
-searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \
-    jg_memo.cmi jg_bind.cmi searchpos.cmi
-searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \
-    jg_memo.cmx jg_bind.cmx searchpos.cmi
-setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \
+searchid.cmo : list2.cmo searchid.cmi
+searchid.cmx : list2.cmx searchid.cmi
+searchpos.cmo : searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi \
+    jg_message.cmi jg_memo.cmi jg_bind.cmi searchpos.cmi
+searchpos.cmx : searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx \
+    jg_message.cmx jg_memo.cmx jg_bind.cmx searchpos.cmi
+setpath.cmo : useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \
     jg_bind.cmi setpath.cmi
-setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \
+setpath.cmx : useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \
     jg_bind.cmx setpath.cmi
-shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \
+shell.cmo : list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \
     jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi
-shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \
+shell.cmx : list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \
     jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi
-typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi
-typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi
-useunix.cmo: useunix.cmi
-useunix.cmx: useunix.cmi
-viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \
+typecheck.cmo : mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \
+    typecheck.cmi
+typecheck.cmx : mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx \
+    typecheck.cmi
+useunix.cmo : useunix.cmi
+useunix.cmx : useunix.cmi
+viewer.cmo : useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \
     mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \
     jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \
     jg_box.cmo jg_bind.cmi help.cmo viewer.cmi
-viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \
+viewer.cmx : useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \
     mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \
     jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \
     jg_box.cmx jg_bind.cmx help.cmx viewer.cmi
-mytypes.cmi: shell.cmi
-typecheck.cmi: mytypes.cmi
+dummy.cmi :
+dummyUnix.cmi :
+dummyWin.cmi :
+editor.cmi :
+fileselect.cmi :
+jg_bind.cmi :
+jg_completion.cmi :
+jg_config.cmi :
+jg_memo.cmi :
+jg_message.cmi :
+jg_multibox.cmi :
+jg_text.cmi :
+lexical.cmi :
+mytypes.cmi : shell.cmi
+searchid.cmi :
+searchpos.cmi :
+setpath.cmi :
+shell.cmi :
+typecheck.cmi : mytypes.cmi
+useunix.cmi :
+viewer.cmi :
diff --git a/otherlibs/labltk/browser/.ignore b/otherlibs/labltk/browser/.ignore
new file mode 100644
index 00000000..8d7632f4
--- /dev/null
+++ b/otherlibs/labltk/browser/.ignore
@@ -0,0 +1,3 @@
+ocamlbrowser
+dummy.mli
+help.ml
diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile
index 5caed2bf..a21973e7 100644
--- a/otherlibs/labltk/browser/Makefile
+++ b/otherlibs/labltk/browser/Makefile
@@ -1,3 +1,17 @@
+#########################################################################
+#                                                                       #
+#                         OCaml LablTk library                          #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 1999 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.                                 #
+#                                                                       #
+#########################################################################
+
 # $Id$
 
 OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str
diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt
index 405f47e7..289b0924 100644
--- a/otherlibs/labltk/browser/Makefile.nt
+++ b/otherlibs/labltk/browser/Makefile.nt
@@ -1,3 +1,17 @@
+#########################################################################
+#                                                                       #
+#                         OCaml LablTk library                          #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 2000 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.                                 #
+#                                                                       #
+#########################################################################
+
 # $Id$
 
 OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads
diff --git a/otherlibs/labltk/browser/Makefile.shared b/otherlibs/labltk/browser/Makefile.shared
index b8096708..35b8edf7 100644
--- a/otherlibs/labltk/browser/Makefile.shared
+++ b/otherlibs/labltk/browser/Makefile.shared
@@ -1,5 +1,19 @@
 include ../support/Makefile.common
 
+#########################################################################
+#                                                                       #
+#                         OCaml LablTk library                          #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 1999 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.                                 #
+#                                                                       #
+#########################################################################
+
 LABLTKLIB=-I ../labltk -I ../lib -I ../support
 OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing
 INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB)
@@ -9,7 +23,7 @@ OBJ =	list2.cmo	useunix.cmo	setpath.cmo	lexical.cmo	\
 	help.cmo	\
 	viewer.cmo	typecheck.cmo	editor.cmo	main.cmo
 
-JG =	jg_tk.cmo	jg_config.cmo	jg_bind.cmo	 jg_completion.cmo \
+JG =	jg_tk.cmo	jg_config.cmo	jg_bind.cmo	jg_completion.cmo \
 	jg_box.cmo \
 	jg_button.cmo	jg_toplevel.cmo	jg_text.cmo	jg_message.cmo \
 	jg_menu.cmo	jg_entry.cmo	jg_multibox.cmo	jg_memo.cmo
@@ -52,9 +66,9 @@ install:
 	  cp ocamlbrowser$(EXE) $(BINDIR); fi
 
 clean:
-	rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O)
+	rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O) help.ml
 
-depend:
+depend: help.ml
 	$(CAMLDEP) *.ml *.mli > .depend
 
 shell.cmo: dummy.cmi
diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli
index 22724192..13736811 100644
--- a/otherlibs/labltk/browser/dummyUnix.mli
+++ b/otherlibs/labltk/browser/dummyUnix.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli
index a4b75ee3..3f8c26e6 100644
--- a/otherlibs/labltk/browser/dummyWin.mli
+++ b/otherlibs/labltk/browser/dummyWin.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
index 617cdfa8..a9f7e6ea 100644
--- a/otherlibs/labltk/browser/editor.ml
+++ b/otherlibs/labltk/browser/editor.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli
index 665ee813..2d5e9049 100644
--- a/otherlibs/labltk/browser/editor.mli
+++ b/otherlibs/labltk/browser/editor.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml
index 22052b42..d62b8ba3 100644
--- a/otherlibs/labltk/browser/fileselect.ml
+++ b/otherlibs/labltk/browser/fileselect.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli
index b723c626..ed10eaf6 100644
--- a/otherlibs/labltk/browser/fileselect.mli
+++ b/otherlibs/labltk/browser/fileselect.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/help.ml b/otherlibs/labltk/browser/help.ml
deleted file mode 100644
index 632e762f..00000000
--- a/otherlibs/labltk/browser/help.ml
+++ /dev/null
@@ -1,168 +0,0 @@
-let text = "\
-\032                         OCamlBrowser Help\n\
-\n\
-USE\n\
-\n\
-\032  OCamlBrowser is composed of three tools, the Editor, which allows\n\
-\032  one to edit/typecheck/analyse .mli and .ml files, the Viewer, to\n\
-\032  walk around compiled modules, and the Shell, to run an OCaml\n\
-\032  subshell. You may only have one instance of Editor and Viewer, but\n\
-\032  you may use several subshells.\n\
-\n\
-\032  As with the compiler, you may specify a different path for the\n\
-\032  standard library by setting OCAMLLIB. You may also extend the\n\
-\032  initial load path (only standard library by default) by using the\n\
-\032  -I command line option. The -nolabels, -rectypes and -w options are\n\
-\032  also accepted, and inherited by subshells.\n\
-\032  The -oldui options selects the old multi-window interface. The\n\
-\032  default is now more like Smalltalk's class browser.\n\
-\n\
-1) Viewer\n\
-\n\
-\032  This is the first window you get when you start OCamlBrowser.  It\n\
-\032  displays a search window, and the list of modules in the load path.\n\
-\032  At the top a row of menus.\n\
-\n\
-\032  File - Open and File - Editor give access to the editor.\n\
-\n\
-\032  File - Shell opens an OCaml shell.\n\
-\n\
-\032  View - Show all defs  displays the signature of the currently\n\
-\032  selected module.\n\
-\n\
-\032  View - Search entry  shows/hides the search entry just\n\
-\032  below the menu bar.\n\
-\n\
-\032  Modules - Path editor changes the load path.\n\
-\032       Pressing [Add to path] or Insert key adds selected directories\n\
-\032       to the load path.\n\
-\032       Pressing [Remove from path] or Delete key removes selected\n\
-\032       paths from the load path.\n\
-\n\
-\032  Modules - Reset cache rescans the load path and resets the module\n\
-\032  cache. Do it if you recompile some interface, or change the load\n\
-\032  path in a conflictual way.\n\
-\n\
-\032  Modules - Search symbol allows to search a symbol either by its\n\
-\032  name, like the bottom line of the viewer, or, more interestingly,\n\
-\032  by its type. Exact type searches for a type with exactly the same\n\
-\032  information as the pattern (variables match only variables),\n\
-\032  included type allows to give only partial information: the actual\n\
-\032  type may take more arguments and return more results, and variables\n\
-\032  in the pattern match anything. In both cases, argument and tuple\n\
-\032  order is irrelevant (*), and unlabeled arguments in the pattern\n\
-\032  match any label.\n\
-\n\
-\032  (*) To avoid combinatorial explosion of the search space, optional\n\
-\032  arguments in the actual type are ignored if (1) there are to many\n\
-\032  of them, and (2) they do not appear explicitly in the pattern.\n\
-\n\
-\032  The Search entry just below the menu bar allows one to search for\n\
-\032  an identifier in all modules, either by its name (? and * patterns\n\
-\032  allowed) or by its type (if there is an arrow in the input). When\n\
-\032  search by type is used, it is done in inclusion mode (cf. Modules -\n\
-\032  search symbol)\n\
-\n\
-\032  The Close all button is there to dismiss the windows created\n\
-\032  by the Detach button. By double-clicking on it you will quit the\n\
-\032  browser.\n\
-\n\
-\n\
-2) Module browsing\n\
-\n\
-\032  You select a module in the leftmost box by either cliking on it or\n\
-\032  pressing return when it is selected. Fast access is available in\n\
-\032  all boxes pressing the first few letter of the desired name.\n\
-\032  Double-clicking / double-return displays the whole signature for\n\
-\032  the module.\n\
-\n\
-\032  Defined identifiers inside the module are displayed in a box to the\n\
-\032  right of the previous one. If you click on one, this will either\n\
-\032  display its contents in another box (if this is a sub-module) or\n\
-\032  display the signature for this identifier below.\n\
-\n\
-\032  Signatures are clickable. Double clicking with the left mouse\n\
-\032  button on an identifier in a signature brings you to its signature,\n\
-\032  inside its module box.\n\
-\032  A single click on the right button pops up a menu displaying the\n\
-\032  type declaration for the selected identifier. Its title, when\n\
-\032  selectable, also brings you to its signature.\n\
-\n\
-\032  At the bottom, a series of buttons, depending on the context.\n\
-\032  * Detach copies the currently displayed signature in a new window,\n\
-\032    to keep it.\n\
-\032  * Impl and Intf bring you to the implementation or interface of\n\
-\032    the currently displayed signature, if it is available.\n\
-\n\
-\032  C-s opens a text search dialog for the displayed signature.\n\
-\n\
-3) File editor\n\
-\n\
-\032  You can edit files with it, but there is no auto-save nor undo at\n\
-\032  the moment. Otherwise you can use it as a browser, making\n\
-\032  occasional corrections.\n\
-\n\
-\032  The Edit menu contains commands for jump (C-g), search (C-s), and\n\
-\032  sending the current selection to a sub-shell (M-x). For this last\n\
-\032  option, you may choose the shell via a dialog.\n\
-\n\
-\032  Essential function are in the Compiler menu.\n\
-\n\
-\032  Preferences opens a dialog to set internals of the editor and\n\
-\032  type checker.\n\
-\n\
-\032  Lex (M-l) adds colors according to lexical categories.\n\
-\n\
-\032  Typecheck (M-t) verifies typing, and memorizes it to let one see an\n\
-\032  expression's type by double-clicking on it. This is also valid for\n\
-\032  interfaces. If an error occurs, the part of the interface preceding\n\
-\032  the error is computed.\n\
-\n\
-\032  After typechecking, pressing the right button pops up a menu giving\n\
-\032  the type of the pointed expression, and eventually allowing to\n\
-\032  follow some links.\n\
-\n\
-\032  Clear errors dismisses type checker error messages and warnings.\n\
-\n\
-\032  Signature shows the signature of the current file.\n\
-\n\
-4) Shell\n\
-\n\
-\032  When you create a shell, a dialog is presented to you, letting you\n\
-\032  choose which command you want to run, and the title of the shell\n\
-\032  (to choose it in the Editor).\n\
-\n\
-\032  You may change the default command by setting the OLABL environment\n\
-\032  variable.\n\
-\n\
-\032  The executed subshell is given the current load path.\n\
-\032  File: use a source file or load a bytecode file.\n\
-\032    You may also import the browser's path into the subprocess.\n\
-\032  History: M-p and M-n browse up and down.\n\
-\032  Signal: C-c interrupts and you can kill the subprocess.\n\
-\n\
-BUGS\n\
-\n\
-* When you quit the editor and some file was modified, a dialogue is\n\
-\032 displayed asking wether you want to really quit or not. But 1) if\n\
-\032 you quit directly from the viewer, there is no dialogue at all, and\n\
-\032 2) if you close from the window manager, the dialogue is displayed,\n\
-\032 but you cannot cancel the destruction... Beware.\n\
-\n\
-* When you run it through xon, the shell hangs at the first error. But\n\
-\032 its ok if you start ocamlbrowser from a remote shell...\n\
-\n\
-TODO\n\
-\n\
-* Complete cross-references.\n\
-\n\
-* Power up editor.\n\
-\n\
-* Add support for the debugger.\n\
-\n\
-* Make this a real programming environment, both for beginners an\n\
-\032 experimented users.\n\
-\n\
-\n\
-Bug reports and comments to \n\
-";;
diff --git a/otherlibs/labltk/browser/help.txt b/otherlibs/labltk/browser/help.txt
index 62bfc592..3b8c9b86 100644
--- a/otherlibs/labltk/browser/help.txt
+++ b/otherlibs/labltk/browser/help.txt
@@ -159,7 +159,7 @@ TODO
 
 * Add support for the debugger.
 
-* Make this a real programming environment, both for beginners an
+* Make this a real programming environment, both for beginners and
   experimented users.
 
 
diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml
index 2e3ec987..3fb854b0 100644
--- a/otherlibs/labltk/browser/jg_bind.ml
+++ b/otherlibs/labltk/browser/jg_bind.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli
index e09c2ba4..70e323be 100644
--- a/otherlibs/labltk/browser/jg_bind.mli
+++ b/otherlibs/labltk/browser/jg_bind.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml
index 3675f4bf..bc865f6d 100644
--- a/otherlibs/labltk/browser/jg_box.ml
+++ b/otherlibs/labltk/browser/jg_box.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml
index 11abd68a..de8d3582 100644
--- a/otherlibs/labltk/browser/jg_button.ml
+++ b/otherlibs/labltk/browser/jg_button.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml
index c93b099b..a5457a65 100644
--- a/otherlibs/labltk/browser/jg_completion.ml
+++ b/otherlibs/labltk/browser/jg_completion.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli
index 69c7a134..40c2db3c 100644
--- a/otherlibs/labltk/browser/jg_completion.mli
+++ b/otherlibs/labltk/browser/jg_completion.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml
index bce0e50e..fbbd2ef1 100644
--- a/otherlibs/labltk/browser/jg_config.ml
+++ b/otherlibs/labltk/browser/jg_config.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli
index 511e2b3a..fdaab3fe 100644
--- a/otherlibs/labltk/browser/jg_config.mli
+++ b/otherlibs/labltk/browser/jg_config.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml
index c09a273e..1f7aab75 100644
--- a/otherlibs/labltk/browser/jg_entry.ml
+++ b/otherlibs/labltk/browser/jg_entry.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml
index e238929a..fb1c05ef 100644
--- a/otherlibs/labltk/browser/jg_memo.ml
+++ b/otherlibs/labltk/browser/jg_memo.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli
index 5491dee3..14443ad1 100644
--- a/otherlibs/labltk/browser/jg_memo.mli
+++ b/otherlibs/labltk/browser/jg_memo.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml
index b399d10d..880ca775 100644
--- a/otherlibs/labltk/browser/jg_menu.ml
+++ b/otherlibs/labltk/browser/jg_menu.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml
index 3c18f193..d4d3ebbd 100644
--- a/otherlibs/labltk/browser/jg_message.ml
+++ b/otherlibs/labltk/browser/jg_message.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli
index 0a83a594..0e123ac2 100644
--- a/otherlibs/labltk/browser/jg_message.mli
+++ b/otherlibs/labltk/browser/jg_message.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml
index febec8e5..39082e32 100644
--- a/otherlibs/labltk/browser/jg_multibox.ml
+++ b/otherlibs/labltk/browser/jg_multibox.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli
index 6dfe7d8f..bccca506 100644
--- a/otherlibs/labltk/browser/jg_multibox.mli
+++ b/otherlibs/labltk/browser/jg_multibox.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml
index 067b9dac..76eeb92a 100644
--- a/otherlibs/labltk/browser/jg_text.ml
+++ b/otherlibs/labltk/browser/jg_text.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli
index e8646dd9..44cba023 100644
--- a/otherlibs/labltk/browser/jg_text.mli
+++ b/otherlibs/labltk/browser/jg_text.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml
index 7fc77f09..16106eeb 100644
--- a/otherlibs/labltk/browser/jg_tk.ml
+++ b/otherlibs/labltk/browser/jg_tk.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml
index 64b6f54d..d77845df 100644
--- a/otherlibs/labltk/browser/jg_toplevel.ml
+++ b/otherlibs/labltk/browser/jg_toplevel.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml
index 72f1957e..a700f728 100644
--- a/otherlibs/labltk/browser/lexical.ml
+++ b/otherlibs/labltk/browser/lexical.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli
index 3be04d32..52d09e35 100644
--- a/otherlibs/labltk/browser/lexical.mli
+++ b/otherlibs/labltk/browser/lexical.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml
index 87b88f49..4439e741 100644
--- a/otherlibs/labltk/browser/list2.ml
+++ b/otherlibs/labltk/browser/list2.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
index 18150696..1d79daa5 100644
--- a/otherlibs/labltk/browser/main.ml
+++ b/otherlibs/labltk/browser/main.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -49,7 +49,7 @@ let check ~spec argv =
 open Printf
 
 let print_version () =
-  printf "The Objective Caml browser, version %s\n" Sys.ocaml_version;
+  printf "The OCaml browser, version %s\n" Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -106,7 +106,7 @@ let _ =
         (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'"
            "Couldn't initialize environment."
            (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB")
-           "points to the Objective Caml library."
+           "points to the OCaml library."
            Config.standard_library)
   end;
 
diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli
index 6db120ad..b4deead2 100644
--- a/otherlibs/labltk/browser/mytypes.mli
+++ b/otherlibs/labltk/browser/mytypes.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 28481439..e624eca9 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -101,7 +101,7 @@ let rec all_args ty =
 
 let rec equal ~prefix t1 t2 =
   match (repr t1).desc, (repr t2).desc with
-    Tvar, Tvar -> true
+    Tvar _, Tvar _ -> true
   | Tvariant row1, Tvariant row2 ->
       let row1 = row_repr row1 and row2 = row_repr row2 in
       let fields1 = filter_row_fields false row1.row_fields
@@ -144,7 +144,7 @@ let get_options = List.filter ~f:is_opt
 
 let rec included ~prefix t1 t2 =
   match (repr t1).desc, (repr t2).desc with
-    Tvar, _ -> true
+    Tvar _, _ -> true
   | Tvariant row1, Tvariant row2 ->
       let row1 = row_repr row1 and row2 = row_repr row2 in
       let fields1 = filter_row_fields false row1.row_fields
@@ -222,6 +222,7 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
           if matches vd.val_type then [lid_of_id id, Pvalue] else []
       | Tsig_type (id, td, _) ->
           if
+          matches (newconstr (Pident id) td.type_params) ||
           begin match td.type_manifest with
             None -> false
           | Some t -> matches t
@@ -229,13 +230,17 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
           begin match td.type_kind with
             Type_abstract -> false
           | Type_variant l ->
-            List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
+            List.exists l ~f:
+            begin fun (_, l, r) ->
+              List.exists l ~f:matches ||
+              match r with None -> false | Some x -> matches x
+            end
           | Type_record(l, rep) ->
             List.exists l ~f:(fun (_, _, t) -> matches t)
           end
           then [lid_of_id id, Ptype] else []
       | Tsig_exception (id, l) ->
-          if List.exists l ~f:matches
+          if List.exists l.exn_args ~f:matches
           then [lid_of_id id, Pconstructor]
           else []
       | Tsig_module (id, Tmty_signature sign, _) ->
@@ -406,7 +411,7 @@ open Parsetree
 
 let rec bound_variables pat =
   match pat.ppat_desc with
-    Ppat_any | Ppat_constant _ | Ppat_type _ -> []
+    Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> []
   | Ppat_var s -> [s]
   | Ppat_alias (pat,s) -> s :: bound_variables pat
   | Ppat_tuple l -> List2.flat_map l ~f:bound_variables
diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli
index 980c141d..9e0c8ad9 100644
--- a/otherlibs/labltk/browser/searchid.mli
+++ b/otherlibs/labltk/browser/searchid.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 8cae9959..2d4b6894 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -170,7 +170,7 @@ let search_pos_type_decl td ~pos ~env =
       Ptype_abstract -> ()
     | Ptype_variant dl ->
         List.iter dl
-          ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+          ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
     | Ptype_record dl ->
         List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
     search_tkind td.ptype_kind;
@@ -397,6 +397,7 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
           match e with
             Syntaxerr.Unclosed(l,_,_,_) -> l
           | Syntaxerr.Applicative_path l -> l
+          | Syntaxerr.Variable_in_scope(l,_) -> l
           | Syntaxerr.Other l -> l
         in
         Jg_text.tag_and_see  tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
@@ -495,7 +496,8 @@ and view_expr_type ?title ?path ?env ?(name="noname") t =
     | Some path -> parent_path path, ident_of_path path ~default:name
   in
   view_signature ~title ?path ?env
-    [Tsig_value (id, {val_type = t; val_kind = Val_reg})]
+    [Tsig_value (id, {val_type = t; val_kind = Val_reg;
+                      val_loc = Location.none})]
 
 and view_decl lid ~kind ~env =
   match kind with
@@ -692,13 +694,6 @@ and search_pos_class_structure ~pos cls =
       | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
       | Cf_val _ -> ()
       | Cf_meth (_, exp) -> search_pos_expr exp ~pos
-      | Cf_let (_, pel, iel) ->
-          List.iter pel ~f:
-            begin fun (pat, exp) ->
-              search_pos_pat pat ~pos ~env:exp.exp_env;
-              search_pos_expr exp ~pos
-            end;
-          List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
       | Cf_init exp -> search_pos_expr exp ~pos
     end
 
diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli
index b2f89cd8..a2d5dfd9 100644
--- a/otherlibs/labltk/browser/searchpos.mli
+++ b/otherlibs/labltk/browser/searchpos.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml
index 1a41b573..01865761 100644
--- a/otherlibs/labltk/browser/setpath.ml
+++ b/otherlibs/labltk/browser/setpath.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli
index 22bf5dc5..6191b70c 100644
--- a/otherlibs/labltk/browser/setpath.mli
+++ b/otherlibs/labltk/browser/setpath.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
index 1f1492de..93525f88 100644
--- a/otherlibs/labltk/browser/shell.ml
+++ b/otherlibs/labltk/browser/shell.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli
index ac94f43d..5bb1ff5a 100644
--- a/otherlibs/labltk/browser/shell.mli
+++ b/otherlibs/labltk/browser/shell.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
index d5347ef5..ac861a6f 100644
--- a/otherlibs/labltk/browser/typecheck.ml
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -60,8 +60,7 @@ let parse_pp ~parse ~wrap ~ext text =
       let ic = open_in_bin tmpfile in
       let ast =
         try
-          let buffer = String.create (String.length ast_magic) in
-          really_input ic buffer 0 (String.length ast_magic);
+          let buffer = Misc.input_bytes ic (String.length ast_magic) in
           if buffer = ast_magic then begin
             ignore (input_value ic);
             wrap (input_value ic)
@@ -73,7 +72,7 @@ let parse_pp ~parse ~wrap ~ext text =
           Outdated_version ->
             close_in ic;
             Sys.remove tmpfile;
-            failwith "Ocaml and preprocessor have incompatible versions"
+            failwith "OCaml and preprocessor have incompatible versions"
         | _ ->
             seek_in ic 0;
             let buffer = Lexing.from_channel ic in
@@ -140,6 +139,7 @@ let f txt =
           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) ->
diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli
index d61fce62..08a16dd2 100644
--- a/otherlibs/labltk/browser/typecheck.mli
+++ b/otherlibs/labltk/browser/typecheck.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml
index 666f866f..86554d48 100644
--- a/otherlibs/labltk/browser/useunix.ml
+++ b/otherlibs/labltk/browser/useunix.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli
index 2850c0d2..47d7a26a 100644
--- a/otherlibs/labltk/browser/useunix.mli
+++ b/otherlibs/labltk/browser/useunix.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index fef3cbe1..72b9c1d6 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -74,7 +74,7 @@ let view_symbol ~kind ~env ?path id =
         Tconstr (cpath, _, _) ->
         if Path.same cpath Predef.path_exn then
           view_signature ~title:(string_of_longident id) ~env ?path
-            [Tsig_exception (Ident.create name, cd.cstr_args)]
+            [Tsig_exception (Ident.create name, {exn_loc = Location.none; exn_args = cd.cstr_args})]
         else
           view_type_decl cpath ~env
       | _ -> ()
diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli
index d8bec671..c56c5e41 100644
--- a/otherlibs/labltk/browser/viewer.mli
+++ b/otherlibs/labltk/browser/viewer.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c
index dd9146fc..4dd06441 100644
--- a/otherlibs/labltk/browser/winmain.c
+++ b/otherlibs/labltk/browser/winmain.c
@@ -1,3 +1,17 @@
+/*************************************************************************/
+/*                                                                       */
+/*                         OCaml LablTk library                          */
+/*                                                                       */
+/*            Jacques Garrigue, Kyoto University RIMS                    */
+/*                                                                       */
+/*   Copyright 2001 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.                                 */
+/*                                                                       */
+/*************************************************************************/
+
 /* $Id$ */
 
 #include 
diff --git a/otherlibs/labltk/builtin/LICENSE b/otherlibs/labltk/builtin/LICENSE
index c006f51d..dbad5f1c 100644
--- a/otherlibs/labltk/builtin/LICENSE
+++ b/otherlibs/labltk/builtin/LICENSE
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*          Francois Rouaix, Francois Pessaux, Jun Furuse                *)
 (*               projet Cristal, INRIA Rocquencourt                      *)
@@ -16,4 +16,4 @@
 
 (* $Id$ *)
 
-All the files in this directory are subject to the above copyright notice.
\ No newline at end of file
+All the files in this directory are subject to the above copyright notice.
diff --git a/otherlibs/labltk/camltk/.cvsignore b/otherlibs/labltk/camltk/.cvsignore
deleted file mode 100644
index 58506764..00000000
--- a/otherlibs/labltk/camltk/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.ml *.mli labltktop labltk
-modules
-.depend
diff --git a/otherlibs/labltk/camltk/.ignore b/otherlibs/labltk/camltk/.ignore
new file mode 100644
index 00000000..81bd183e
--- /dev/null
+++ b/otherlibs/labltk/camltk/.ignore
@@ -0,0 +1,4 @@
+*.ml
+*.mli
+labltktop
+labltk
diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile
index 19300ead..62c22d3a 100644
--- a/otherlibs/labltk/camltk/Makefile
+++ b/otherlibs/labltk/camltk/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 ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix
diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen
index f25e1f76..9ec1972c 100644
--- a/otherlibs/labltk/camltk/Makefile.gen
+++ b/otherlibs/labltk/camltk/Makefile.gen
@@ -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
 
 all: cTk.ml camltk.ml .depend
diff --git a/otherlibs/labltk/camltk/modules b/otherlibs/labltk/camltk/modules
index c1a2eed8..723783aa 100644
--- a/otherlibs/labltk/camltk/modules
+++ b/otherlibs/labltk/camltk/modules
@@ -1,80 +1,80 @@
-CWIDGETOBJS=cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo 
-cPlace.ml cResource.ml cWm.ml cImagephoto.ml cCanvas.ml cButton.ml cText.ml cLabel.ml cScrollbar.ml cImage.ml cEncoding.ml cPixmap.ml cPalette.ml cFont.ml cMessage.ml cMenu.ml cEntry.ml cListbox.ml cFocus.ml cMenubutton.ml cPack.ml cOption.ml cToplevel.ml cFrame.ml cDialog.ml cImagebitmap.ml cClipboard.ml cRadiobutton.ml cTkwait.ml cGrab.ml cSelection.ml cScale.ml cOptionmenu.ml cWinfo.ml cGrid.ml cCheckbutton.ml cBell.ml cTkvars.ml : _tkgen.ml
+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
 
-cPlace.cmo : cPlace.ml
-cPlace.cmi : cPlace.mli
-cResource.cmo : cResource.ml
-cResource.cmi : cResource.mli
+cBell.cmo : cBell.ml
+cBell.cmi : cBell.mli
+cScale.cmo : cScale.ml
+cScale.cmi : cScale.mli
+cWinfo.cmo : cWinfo.ml
+cWinfo.cmi : cWinfo.mli
+cScrollbar.cmo : cScrollbar.ml
+cScrollbar.cmi : cScrollbar.mli
+cEntry.cmo : cEntry.ml
+cEntry.cmi : cEntry.mli
+cListbox.cmo : cListbox.ml
+cListbox.cmi : cListbox.mli
 cWm.cmo : cWm.ml
 cWm.cmi : cWm.mli
-cImagephoto.cmo : cImagephoto.ml
-cImagephoto.cmi : cImagephoto.mli
+cTkwait.cmo : cTkwait.ml
+cTkwait.cmi : cTkwait.mli
+cGrab.cmo : cGrab.ml
+cGrab.cmi : cGrab.mli
+cFont.cmo : cFont.ml
+cFont.cmi : cFont.mli
 cCanvas.cmo : cCanvas.ml
 cCanvas.cmi : cCanvas.mli
-cButton.cmo : cButton.ml
-cButton.cmi : cButton.mli
-cText.cmo : cText.ml
-cText.cmi : cText.mli
-cLabel.cmo : cLabel.ml
-cLabel.cmi : cLabel.mli
-cScrollbar.cmo : cScrollbar.ml
-cScrollbar.cmi : cScrollbar.mli
 cImage.cmo : cImage.ml
 cImage.cmi : cImage.mli
-cEncoding.cmo : cEncoding.ml
-cEncoding.cmi : cEncoding.mli
-cPixmap.cmo : cPixmap.ml
-cPixmap.cmi : cPixmap.mli
-cPalette.cmo : cPalette.ml
-cPalette.cmi : cPalette.mli
-cFont.cmo : cFont.ml
-cFont.cmi : cFont.mli
+cClipboard.cmo : cClipboard.ml
+cClipboard.cmi : cClipboard.mli
+cLabel.cmo : cLabel.ml
+cLabel.cmi : cLabel.mli
+cResource.cmo : cResource.ml
+cResource.cmi : cResource.mli
 cMessage.cmo : cMessage.ml
 cMessage.cmi : cMessage.mli
-cMenu.cmo : cMenu.ml
-cMenu.cmi : cMenu.mli
-cEntry.cmo : cEntry.ml
-cEntry.cmi : cEntry.mli
-cListbox.cmo : cListbox.ml
-cListbox.cmi : cListbox.mli
-cFocus.cmo : cFocus.ml
-cFocus.cmi : cFocus.mli
-cMenubutton.cmo : cMenubutton.ml
-cMenubutton.cmi : cMenubutton.mli
-cPack.cmo : cPack.ml
-cPack.cmi : cPack.mli
+cText.cmo : cText.ml
+cText.cmi : cText.mli
+cImagephoto.cmo : cImagephoto.ml
+cImagephoto.cmi : cImagephoto.mli
 cOption.cmo : cOption.ml
 cOption.cmi : cOption.mli
-cToplevel.cmo : cToplevel.ml
-cToplevel.cmi : cToplevel.mli
 cFrame.cmo : cFrame.ml
 cFrame.cmi : cFrame.mli
+cSelection.cmo : cSelection.ml
+cSelection.cmi : cSelection.mli
 cDialog.cmo : cDialog.ml
 cDialog.cmi : cDialog.mli
-cImagebitmap.cmo : cImagebitmap.ml
-cImagebitmap.cmi : cImagebitmap.mli
-cClipboard.cmo : cClipboard.ml
-cClipboard.cmi : cClipboard.mli
+cPlace.cmo : cPlace.ml
+cPlace.cmi : cPlace.mli
+cPixmap.cmo : cPixmap.ml
+cPixmap.cmi : cPixmap.mli
+cMenubutton.cmo : cMenubutton.ml
+cMenubutton.cmi : cMenubutton.mli
 cRadiobutton.cmo : cRadiobutton.ml
 cRadiobutton.cmi : cRadiobutton.mli
-cTkwait.cmo : cTkwait.ml
-cTkwait.cmi : cTkwait.mli
-cGrab.cmo : cGrab.ml
-cGrab.cmi : cGrab.mli
-cSelection.cmo : cSelection.ml
-cSelection.cmi : cSelection.mli
-cScale.cmo : cScale.ml
-cScale.cmi : cScale.mli
+cFocus.cmo : cFocus.ml
+cFocus.cmi : cFocus.mli
+cPack.cmo : cPack.ml
+cPack.cmi : cPack.mli
+cImagebitmap.cmo : cImagebitmap.ml
+cImagebitmap.cmi : cImagebitmap.mli
+cEncoding.cmo : cEncoding.ml
+cEncoding.cmi : cEncoding.mli
 cOptionmenu.cmo : cOptionmenu.ml
 cOptionmenu.cmi : cOptionmenu.mli
-cWinfo.cmo : cWinfo.ml
-cWinfo.cmi : cWinfo.mli
-cGrid.cmo : cGrid.ml
-cGrid.cmi : cGrid.mli
 cCheckbutton.cmo : cCheckbutton.ml
 cCheckbutton.cmi : cCheckbutton.mli
-cBell.cmo : cBell.ml
-cBell.cmi : cBell.mli
 cTkvars.cmo : cTkvars.ml
 cTkvars.cmi : cTkvars.mli
-camltk.cmo : cTk.cmo cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo 
+cPalette.cmo : cPalette.ml
+cPalette.cmi : cPalette.mli
+cMenu.cmo : cMenu.ml
+cMenu.cmi : cMenu.mli
+cButton.cmo : cButton.ml
+cButton.cmi : cButton.mli
+cToplevel.cmo : cToplevel.ml
+cToplevel.cmi : cToplevel.mli
+cGrid.cmo : cGrid.ml
+cGrid.cmi : cGrid.mli
+camltk.cmo : cTk.cmo 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 
diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore
deleted file mode 100644
index 060114e6..00000000
--- a/otherlibs/labltk/compiler/.cvsignore
+++ /dev/null
@@ -1,11 +0,0 @@
-lexer.ml
-parser.output
-parser.ml
-parser.mli
-tkcompiler
-pp
-copyright.ml
-pplex.ml
-ppyac.ml
-ppyac.output
-ppyac.mli
diff --git a/otherlibs/labltk/compiler/.ignore b/otherlibs/labltk/compiler/.ignore
new file mode 100644
index 00000000..060114e6
--- /dev/null
+++ b/otherlibs/labltk/compiler/.ignore
@@ -0,0 +1,11 @@
+lexer.ml
+parser.output
+parser.ml
+parser.mli
+tkcompiler
+pp
+copyright.ml
+pplex.ml
+ppyac.ml
+ppyac.output
+ppyac.mli
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
index b7db380f..f6e58454 100644
--- a/otherlibs/labltk/compiler/Makefile
+++ b/otherlibs/labltk/compiler/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 1999 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
 
 OBJS=	../support/support.cmo flags.cmo copyright.cmo \
diff --git a/otherlibs/labltk/compiler/code.mli b/otherlibs/labltk/compiler/code.mli
index 6f3e2921..bde9c445 100644
--- a/otherlibs/labltk/compiler/code.mli
+++ b/otherlibs/labltk/compiler/code.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index fd74bc17..029cce70 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -548,7 +548,7 @@ let write_TKtoCAML ~w name ~def:typdef =
 (* Converters                 *)
 (******************************)
 
-(* Produce an in-lined converter Caml -> Tk for simple types *)
+(* Produce an in-lined converter OCaml -> Tk for simple types *)
 (* the converter is a function of type:   -> string  *)
 let rec converterCAMLtoTK ~context_widget argname ty =
  match ty with
diff --git a/otherlibs/labltk/compiler/copyright b/otherlibs/labltk/compiler/copyright
index 23dff46d..87ab0d30 100644
--- a/otherlibs/labltk/compiler/copyright
+++ b/otherlibs/labltk/compiler/copyright
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,6 +10,6 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
diff --git a/otherlibs/labltk/compiler/flags.ml b/otherlibs/labltk/compiler/flags.ml
index 009d5e72..d832b494 100644
--- a/otherlibs/labltk/compiler/flags.ml
+++ b/otherlibs/labltk/compiler/flags.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 59608b38..42ad1b38 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index f51f0c01..2fc2376e 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index d8c72a31..91b6bcdf 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
index 15ced65f..6dc7aff3 100644
--- a/otherlibs/labltk/compiler/parser.mly
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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.                                      */
+/*  described in file ../../../LICENSE.                                */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/otherlibs/labltk/compiler/pp.ml b/otherlibs/labltk/compiler/pp.ml
index 5c46766a..c6d4f798 100644
--- a/otherlibs/labltk/compiler/pp.ml
+++ b/otherlibs/labltk/compiler/pp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml
index 71118b96..dd66928c 100644
--- a/otherlibs/labltk/compiler/ppexec.ml
+++ b/otherlibs/labltk/compiler/ppexec.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/pplex.mli b/otherlibs/labltk/compiler/pplex.mli
index 4eaa183b..0502fc90 100644
--- a/otherlibs/labltk/compiler/pplex.mli
+++ b/otherlibs/labltk/compiler/pplex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll
index 313d1f2d..6559d8e9 100644
--- a/otherlibs/labltk/compiler/pplex.mll
+++ b/otherlibs/labltk/compiler/pplex.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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.                                      *)
+(*  described in file ../../../LICENSE.                                *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml
index 630d675d..2b0fdbf8 100644
--- a/otherlibs/labltk/compiler/ppparse.ml
+++ b/otherlibs/labltk/compiler/ppparse.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/ppyac.mly b/otherlibs/labltk/compiler/ppyac.mly
index da7ee681..f92ef966 100644
--- a/otherlibs/labltk/compiler/ppyac.mly
+++ b/otherlibs/labltk/compiler/ppyac.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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.                                      */
+/*  described in file ../../../LICENSE.                                */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml
index be70612a..fe33ada3 100644
--- a/otherlibs/labltk/compiler/printer.ml
+++ b/otherlibs/labltk/compiler/printer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index 0663dfaa..a86b4af5 100644
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
index 6496eaae..6768d0d7 100644
--- a/otherlibs/labltk/compiler/tsort.ml
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_camltk/.cvsignore b/otherlibs/labltk/examples_camltk/.cvsignore
deleted file mode 100644
index 801812fd..00000000
--- a/otherlibs/labltk/examples_camltk/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-addition
-eyes
-fileinput
-fileopen
-helloworld
-tetris
-winskel
-mytext
diff --git a/otherlibs/labltk/examples_camltk/.ignore b/otherlibs/labltk/examples_camltk/.ignore
new file mode 100644
index 00000000..801812fd
--- /dev/null
+++ b/otherlibs/labltk/examples_camltk/.ignore
@@ -0,0 +1,8 @@
+addition
+eyes
+fileinput
+fileopen
+helloworld
+tetris
+winskel
+mytext
diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml
index d4b333dc..44988370 100644
--- a/otherlibs/labltk/examples_camltk/addition.ml
+++ b/otherlibs/labltk/examples_camltk/addition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml
index c9314623..b7636de4 100644
--- a/otherlibs/labltk/examples_camltk/eyes.ml
+++ b/otherlibs/labltk/examples_camltk/eyes.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,11 +10,11 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
-(* The eyes of Caml (CamlTk) *)
+(* The eyes of OCaml (CamlTk) *)
 
 open Camltk;;
 
diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml
index c6190bdd..70bc675b 100644
--- a/otherlibs/labltk/examples_camltk/fileinput.ml
+++ b/otherlibs/labltk/examples_camltk/fileinput.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk ;;
diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml
index 927c2485..d0829bd2 100644
--- a/otherlibs/labltk/examples_camltk/fileopen.ml
+++ b/otherlibs/labltk/examples_camltk/fileopen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk;;
diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml
index bb99d9dd..9829fca8 100644
--- a/otherlibs/labltk/examples_camltk/helloworld.ml
+++ b/otherlibs/labltk/examples_camltk/helloworld.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk;;            (* Make interface functions available *)
diff --git a/otherlibs/labltk/examples_camltk/jptest.ml b/otherlibs/labltk/examples_camltk/jptest.ml
index 38d9694c..9ec06aca 100644
--- a/otherlibs/labltk/examples_camltk/jptest.ml
+++ b/otherlibs/labltk/examples_camltk/jptest.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Tk
diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml
index d4c0d00b..f3aadfbb 100644
--- a/otherlibs/labltk/examples_camltk/mytext.ml
+++ b/otherlibs/labltk/examples_camltk/mytext.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml
index 492fdc92..485c2586 100644
--- a/otherlibs/labltk/examples_camltk/socketinput.ml
+++ b/otherlibs/labltk/examples_camltk/socketinput.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml
index 990812d7..c1867303 100644
--- a/otherlibs/labltk/examples_camltk/taddition.ml
+++ b/otherlibs/labltk/examples_camltk/taddition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Tk
diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml
index 83534347..14a9b648 100644
--- a/otherlibs/labltk/examples_camltk/tetris.ml
+++ b/otherlibs/labltk/examples_camltk/tetris.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml
index 35273377..0f876337 100644
--- a/otherlibs/labltk/examples_camltk/text.ml
+++ b/otherlibs/labltk/examples_camltk/text.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Tk
diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml
index cf68178a..c83e6436 100644
--- a/otherlibs/labltk/examples_camltk/winskel.ml
+++ b/otherlibs/labltk/examples_camltk/winskel.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* This examples is based on Ousterhout's book (fig 16.15) *)
diff --git a/otherlibs/labltk/examples_labltk/.cvsignore b/otherlibs/labltk/examples_labltk/.cvsignore
deleted file mode 100644
index c1f6ec64..00000000
--- a/otherlibs/labltk/examples_labltk/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-calc
-clock
-demo
-eyes
-hello
-tetris
-lang
-taquin
diff --git a/otherlibs/labltk/examples_labltk/.ignore b/otherlibs/labltk/examples_labltk/.ignore
new file mode 100644
index 00000000..c1f6ec64
--- /dev/null
+++ b/otherlibs/labltk/examples_labltk/.ignore
@@ -0,0 +1,8 @@
+calc
+clock
+demo
+eyes
+hello
+tetris
+lang
+taquin
diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml
index 088bf192..17a410c8 100644
--- a/otherlibs/labltk/examples_labltk/calc.ml
+++ b/otherlibs/labltk/examples_labltk/calc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml
index 57a59b82..6903acb2 100644
--- a/otherlibs/labltk/examples_labltk/clock.ml
+++ b/otherlibs/labltk/examples_labltk/clock.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml
index bd36f3f3..9524c1c7 100644
--- a/otherlibs/labltk/examples_labltk/demo.ml
+++ b/otherlibs/labltk/examples_labltk/demo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml
index 81f6aa4a..a96e0826 100644
--- a/otherlibs/labltk/examples_labltk/eyes.ml
+++ b/otherlibs/labltk/examples_labltk/eyes.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml
index 3f39d546..838b50ff 100644
--- a/otherlibs/labltk/examples_labltk/hello.ml
+++ b/otherlibs/labltk/examples_labltk/hello.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml
index cde36399..0d6ba8c9 100644
--- a/otherlibs/labltk/examples_labltk/lang.ml
+++ b/otherlibs/labltk/examples_labltk/lang.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml
index 28099351..616f38cb 100644
--- a/otherlibs/labltk/examples_labltk/taquin.ml
+++ b/otherlibs/labltk/examples_labltk/taquin.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml
index 4f401e59..8260fc20 100644
--- a/otherlibs/labltk/examples_labltk/tetris.ml
+++ b/otherlibs/labltk/examples_labltk/tetris.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/frx/.cvsignore b/otherlibs/labltk/frx/.cvsignore
deleted file mode 100644
index 10301e28..00000000
--- a/otherlibs/labltk/frx/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.a
diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile
index 192034cf..581200b0 100644
--- a/otherlibs/labltk/frx/Makefile
+++ b/otherlibs/labltk/frx/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 ../camltk -I ../support
diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml
index 7fe6a4f2..1b7dfef8 100644
--- a/otherlibs/labltk/frx/frx_after.ml
+++ b/otherlibs/labltk/frx/frx_after.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Protocol
diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli
index 73c07f7b..45e30456 100644
--- a/otherlibs/labltk/frx/frx_after.mli
+++ b/otherlibs/labltk/frx/frx_after.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val idle : (unit -> unit) -> unit
diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml
index 140e1387..e3e616a9 100644
--- a/otherlibs/labltk/frx/frx_color.ml
+++ b/otherlibs/labltk/frx/frx_color.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli
index 513cb083..b2791655 100644
--- a/otherlibs/labltk/frx/frx_color.mli
+++ b/otherlibs/labltk/frx/frx_color.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val check : string -> bool
diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml
index 7d3cbb15..498fe8ec 100644
--- a/otherlibs/labltk/frx/frx_ctext.ml
+++ b/otherlibs/labltk/frx/frx_ctext.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* A trick by Steve Ball to do pixel scrolling on text widgets *)
diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli
index e539f5a8..2f696abe 100644
--- a/otherlibs/labltk/frx/frx_ctext.mli
+++ b/otherlibs/labltk/frx/frx_ctext.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml
index 12289de6..096812db 100644
--- a/otherlibs/labltk/frx/frx_dialog.ml
+++ b/otherlibs/labltk/frx/frx_dialog.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli
index cd256acb..fd816d34 100644
--- a/otherlibs/labltk/frx/frx_dialog.mli
+++ b/otherlibs/labltk/frx/frx_dialog.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml
index ec842218..0b7c339a 100644
--- a/otherlibs/labltk/frx/frx_entry.ml
+++ b/otherlibs/labltk/frx/frx_entry.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli
index 2f34a7e6..0b09f16d 100644
--- a/otherlibs/labltk/frx/frx_entry.mli
+++ b/otherlibs/labltk/frx/frx_entry.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml
index de136867..dfba7a0f 100644
--- a/otherlibs/labltk/frx/frx_fileinput.ml
+++ b/otherlibs/labltk/frx/frx_fileinput.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml
index 611b55a5..143bea4a 100644
--- a/otherlibs/labltk/frx/frx_fillbox.ml
+++ b/otherlibs/labltk/frx/frx_fillbox.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli
index a825524c..9cfc9e78 100644
--- a/otherlibs/labltk/frx/frx_fillbox.mli
+++ b/otherlibs/labltk/frx/frx_fillbox.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml
index c03d6997..bcfd457a 100644
--- a/otherlibs/labltk/frx/frx_fit.ml
+++ b/otherlibs/labltk/frx/frx_fit.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli
index 29479d80..e6149645 100644
--- a/otherlibs/labltk/frx/frx_fit.mli
+++ b/otherlibs/labltk/frx/frx_fit.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml
index ce855e20..29eba574 100644
--- a/otherlibs/labltk/frx/frx_focus.ml
+++ b/otherlibs/labltk/frx/frx_focus.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli
index 919f7047..dcb9317f 100644
--- a/otherlibs/labltk/frx/frx_focus.mli
+++ b/otherlibs/labltk/frx/frx_focus.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml
index 3b739a65..4acb5997 100644
--- a/otherlibs/labltk/frx/frx_font.ml
+++ b/otherlibs/labltk/frx/frx_font.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli
index 8dd99973..4ed235f4 100644
--- a/otherlibs/labltk/frx/frx_font.mli
+++ b/otherlibs/labltk/frx/frx_font.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val find : string -> string -> string -> int -> string
diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml
index 17c8a031..1adc2d88 100644
--- a/otherlibs/labltk/frx/frx_group.ml
+++ b/otherlibs/labltk/frx/frx_group.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml
index c4d51f7b..82ea8a8c 100644
--- a/otherlibs/labltk/frx/frx_lbutton.ml
+++ b/otherlibs/labltk/frx/frx_lbutton.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli
index 60c26a5b..5522e5c2 100644
--- a/otherlibs/labltk/frx/frx_lbutton.mli
+++ b/otherlibs/labltk/frx/frx_lbutton.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Widget
diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml
index 17d6a3f9..6d04262b 100644
--- a/otherlibs/labltk/frx/frx_listbox.ml
+++ b/otherlibs/labltk/frx/frx_listbox.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli
index b44b6ee9..54e7ec6a 100644
--- a/otherlibs/labltk/frx/frx_listbox.mli
+++ b/otherlibs/labltk/frx/frx_listbox.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml
index 37af2083..6df0da75 100644
--- a/otherlibs/labltk/frx/frx_mem.ml
+++ b/otherlibs/labltk/frx/frx_mem.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Memory gauge *)
diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli
index f3069ec2..190297b5 100644
--- a/otherlibs/labltk/frx/frx_mem.mli
+++ b/otherlibs/labltk/frx/frx_mem.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,10 +10,10 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
-(* A Garbage Collector Gauge for Caml *)
+(* A Garbage Collector Gauge for OCaml *)
 
 val init : unit -> unit
   (* [init ()] creates the gauge and its updater, but keeps it iconified *)
diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml
index 75c8a3e4..e45c5f0f 100644
--- a/otherlibs/labltk/frx/frx_misc.ml
+++ b/otherlibs/labltk/frx/frx_misc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Delayed global, a.k.a cache&carry *)
diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli
index 2df8ce3d..cd3d589f 100644
--- a/otherlibs/labltk/frx/frx_misc.mli
+++ b/otherlibs/labltk/frx/frx_misc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml
index ab7308fa..41590c14 100644
--- a/otherlibs/labltk/frx/frx_req.ml
+++ b/otherlibs/labltk/frx/frx_req.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli
index 41de7df3..62985b9f 100644
--- a/otherlibs/labltk/frx/frx_req.mli
+++ b/otherlibs/labltk/frx/frx_req.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Various dialog boxes *)
diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml
index 5f29cbce..5de7a15d 100644
--- a/otherlibs/labltk/frx/frx_rpc.ml
+++ b/otherlibs/labltk/frx/frx_rpc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Some notion of RPC *)
diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli
index 808fe87c..20811738 100644
--- a/otherlibs/labltk/frx/frx_rpc.mli
+++ b/otherlibs/labltk/frx/frx_rpc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Some notion of RPC *)
diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml
index 7ef64ce8..ad037ce2 100644
--- a/otherlibs/labltk/frx/frx_selection.ml
+++ b/otherlibs/labltk/frx/frx_selection.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* A selection handler *)
diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli
index dfb27ee2..b1526583 100644
--- a/otherlibs/labltk/frx/frx_selection.mli
+++ b/otherlibs/labltk/frx/frx_selection.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val set : string -> unit
diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml
index 76b83b64..21bd7fa8 100644
--- a/otherlibs/labltk/frx/frx_synth.ml
+++ b/otherlibs/labltk/frx/frx_synth.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Some notion of synthetic events *)
diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli
index 0b8d85d8..e5a96aa8 100644
--- a/otherlibs/labltk/frx/frx_synth.mli
+++ b/otherlibs/labltk/frx/frx_synth.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Synthetic events *)
diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml
index 18d9961f..a9ca17a3 100644
--- a/otherlibs/labltk/frx/frx_text.ml
+++ b/otherlibs/labltk/frx/frx_text.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli
index ac038443..97783fa9 100644
--- a/otherlibs/labltk/frx/frx_text.mli
+++ b/otherlibs/labltk/frx/frx_text.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli
index 3608e1e5..628cde20 100644
--- a/otherlibs/labltk/frx/frx_toplevel.mli
+++ b/otherlibs/labltk/frx/frx_toplevel.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Widget
diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml
index a81c768f..90451343 100644
--- a/otherlibs/labltk/frx/frx_widget.ml
+++ b/otherlibs/labltk/frx/frx_widget.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli
index ff26749c..f856664c 100644
--- a/otherlibs/labltk/frx/frx_widget.mli
+++ b/otherlibs/labltk/frx/frx_widget.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk
diff --git a/otherlibs/labltk/jpf/.cvsignore b/otherlibs/labltk/jpf/.cvsignore
deleted file mode 100644
index 10301e28..00000000
--- a/otherlibs/labltk/jpf/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.a
diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile
index a79b3d56..a768b139 100644
--- a/otherlibs/labltk/jpf/Makefile
+++ b/otherlibs/labltk/jpf/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 1999 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 ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix -I $(OTHERS)/str
diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
index 739a8d9e..e880f277 100644
--- a/otherlibs/labltk/jpf/balloon.ml
+++ b/otherlibs/labltk/jpf/balloon.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli
index 633796ce..f3e65269 100644
--- a/otherlibs/labltk/jpf/balloon.mli
+++ b/otherlibs/labltk/jpf/balloon.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml
index 60e3aded..236f6174 100644
--- a/otherlibs/labltk/jpf/balloontest.ml
+++ b/otherlibs/labltk/jpf/balloontest.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
index 3d42ac2d..23aaeb6d 100644
--- a/otherlibs/labltk/jpf/fileselect.ml
+++ b/otherlibs/labltk/jpf/fileselect.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli
index 4412a418..42f7d34f 100644
--- a/otherlibs/labltk/jpf/fileselect.mli
+++ b/otherlibs/labltk/jpf/fileselect.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml
index 24b87b7c..b036d421 100644
--- a/otherlibs/labltk/jpf/jpf_font.ml
+++ b/otherlibs/labltk/jpf/jpf_font.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* find font information *)
diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli
index 03f705f5..f3045a9c 100644
--- a/otherlibs/labltk/jpf/jpf_font.mli
+++ b/otherlibs/labltk/jpf/jpf_font.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val debug : bool ref
diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml
index 8b00a8f2..0d566e05 100644
--- a/otherlibs/labltk/jpf/shell.ml
+++ b/otherlibs/labltk/jpf/shell.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Unix
diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli
index c3fec3a2..7c7dd8e1 100644
--- a/otherlibs/labltk/jpf/shell.mli
+++ b/otherlibs/labltk/jpf/shell.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val subshell : string -> string list
diff --git a/otherlibs/labltk/labltk/.cvsignore b/otherlibs/labltk/labltk/.cvsignore
deleted file mode 100644
index 58506764..00000000
--- a/otherlibs/labltk/labltk/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.ml *.mli labltktop labltk
-modules
-.depend
diff --git a/otherlibs/labltk/labltk/.ignore b/otherlibs/labltk/labltk/.ignore
new file mode 100644
index 00000000..81bd183e
--- /dev/null
+++ b/otherlibs/labltk/labltk/.ignore
@@ -0,0 +1,4 @@
+*.ml
+*.mli
+labltktop
+labltk
diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile
index f678954e..1510de8f 100644
--- a/otherlibs/labltk/labltk/Makefile
+++ b/otherlibs/labltk/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 ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix
diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen
index 592ea446..2e1fc274 100644
--- a/otherlibs/labltk/labltk/Makefile.gen
+++ b/otherlibs/labltk/labltk/Makefile.gen
@@ -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
 
 all: tk.ml labltk.ml .depend
diff --git a/otherlibs/labltk/labltk/modules b/otherlibs/labltk/labltk/modules
index a17b6ab1..bb8d3e5b 100644
--- a/otherlibs/labltk/labltk/modules
+++ b/otherlibs/labltk/labltk/modules
@@ -1,77 +1,77 @@
-WIDGETOBJS=place.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo 
-place.ml wm.ml imagephoto.ml canvas.ml button.ml text.ml label.ml scrollbar.ml image.ml encoding.ml pixmap.ml palette.ml font.ml message.ml menu.ml entry.ml listbox.ml focus.ml menubutton.ml pack.ml option.ml toplevel.ml frame.ml dialog.ml imagebitmap.ml clipboard.ml radiobutton.ml tkwait.ml grab.ml selection.ml scale.ml optionmenu.ml winfo.ml grid.ml checkbutton.ml bell.ml tkvars.ml : _tkgen.ml
+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
 
-place.cmo : place.ml
-place.cmi : place.mli
+bell.cmo : bell.ml
+bell.cmi : bell.mli
+scale.cmo : scale.ml
+scale.cmi : scale.mli
+winfo.cmo : winfo.ml
+winfo.cmi : winfo.mli
+scrollbar.cmo : scrollbar.ml
+scrollbar.cmi : scrollbar.mli
+entry.cmo : entry.ml
+entry.cmi : entry.mli
+listbox.cmo : listbox.ml
+listbox.cmi : listbox.mli
 wm.cmo : wm.ml
 wm.cmi : wm.mli
-imagephoto.cmo : imagephoto.ml
-imagephoto.cmi : imagephoto.mli
+tkwait.cmo : tkwait.ml
+tkwait.cmi : tkwait.mli
+grab.cmo : grab.ml
+grab.cmi : grab.mli
+font.cmo : font.ml
+font.cmi : font.mli
 canvas.cmo : canvas.ml
 canvas.cmi : canvas.mli
-button.cmo : button.ml
-button.cmi : button.mli
-text.cmo : text.ml
-text.cmi : text.mli
-label.cmo : label.ml
-label.cmi : label.mli
-scrollbar.cmo : scrollbar.ml
-scrollbar.cmi : scrollbar.mli
 image.cmo : image.ml
 image.cmi : image.mli
-encoding.cmo : encoding.ml
-encoding.cmi : encoding.mli
-pixmap.cmo : pixmap.ml
-pixmap.cmi : pixmap.mli
-palette.cmo : palette.ml
-palette.cmi : palette.mli
-font.cmo : font.ml
-font.cmi : font.mli
+clipboard.cmo : clipboard.ml
+clipboard.cmi : clipboard.mli
+label.cmo : label.ml
+label.cmi : label.mli
 message.cmo : message.ml
 message.cmi : message.mli
-menu.cmo : menu.ml
-menu.cmi : menu.mli
-entry.cmo : entry.ml
-entry.cmi : entry.mli
-listbox.cmo : listbox.ml
-listbox.cmi : listbox.mli
-focus.cmo : focus.ml
-focus.cmi : focus.mli
-menubutton.cmo : menubutton.ml
-menubutton.cmi : menubutton.mli
-pack.cmo : pack.ml
-pack.cmi : pack.mli
+text.cmo : text.ml
+text.cmi : text.mli
+imagephoto.cmo : imagephoto.ml
+imagephoto.cmi : imagephoto.mli
 option.cmo : option.ml
 option.cmi : option.mli
-toplevel.cmo : toplevel.ml
-toplevel.cmi : toplevel.mli
 frame.cmo : frame.ml
 frame.cmi : frame.mli
+selection.cmo : selection.ml
+selection.cmi : selection.mli
 dialog.cmo : dialog.ml
 dialog.cmi : dialog.mli
-imagebitmap.cmo : imagebitmap.ml
-imagebitmap.cmi : imagebitmap.mli
-clipboard.cmo : clipboard.ml
-clipboard.cmi : clipboard.mli
+place.cmo : place.ml
+place.cmi : place.mli
+pixmap.cmo : pixmap.ml
+pixmap.cmi : pixmap.mli
+menubutton.cmo : menubutton.ml
+menubutton.cmi : menubutton.mli
 radiobutton.cmo : radiobutton.ml
 radiobutton.cmi : radiobutton.mli
-tkwait.cmo : tkwait.ml
-tkwait.cmi : tkwait.mli
-grab.cmo : grab.ml
-grab.cmi : grab.mli
-selection.cmo : selection.ml
-selection.cmi : selection.mli
-scale.cmo : scale.ml
-scale.cmi : scale.mli
+focus.cmo : focus.ml
+focus.cmi : focus.mli
+pack.cmo : pack.ml
+pack.cmi : pack.mli
+imagebitmap.cmo : imagebitmap.ml
+imagebitmap.cmi : imagebitmap.mli
+encoding.cmo : encoding.ml
+encoding.cmi : encoding.mli
 optionmenu.cmo : optionmenu.ml
 optionmenu.cmi : optionmenu.mli
-winfo.cmo : winfo.ml
-winfo.cmi : winfo.mli
-grid.cmo : grid.ml
-grid.cmi : grid.mli
 checkbutton.cmo : checkbutton.ml
 checkbutton.cmi : checkbutton.mli
-bell.cmo : bell.ml
-bell.cmi : bell.mli
 tkvars.cmo : tkvars.ml
 tkvars.cmi : tkvars.mli
+palette.cmo : palette.ml
+palette.cmi : palette.mli
+menu.cmo : menu.ml
+menu.cmi : menu.mli
+button.cmo : button.ml
+button.cmi : button.mli
+toplevel.cmo : toplevel.ml
+toplevel.cmi : toplevel.mli
+grid.cmo : grid.ml
+grid.cmi : grid.mli
diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore
deleted file mode 100644
index 02d049a4..00000000
--- a/otherlibs/labltk/lib/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-labltktop labltk mltktop mltk
-.depend
-*.ml
-*.mli
-modules
-labltk.cma
-labltk.cmxa
-*.a
diff --git a/otherlibs/labltk/lib/.ignore b/otherlibs/labltk/lib/.ignore
new file mode 100644
index 00000000..005295fc
--- /dev/null
+++ b/otherlibs/labltk/lib/.ignore
@@ -0,0 +1,7 @@
+labltktop
+labltk
+mltktop
+mltk
+.depend
+*.ml
+*.mli
diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile
index b82bcddf..35ba8ff6 100644
--- a/otherlibs/labltk/lib/Makefile
+++ b/otherlibs/labltk/lib/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 1999 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
 
 all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME)
@@ -55,7 +71,7 @@ $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A)
 $(LIBNAME): Makefile $(TOPDIR)/config/Makefile
 	@echo Generate $@
 	@echo "#!/bin/sh" > $@
-	@echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@
+	@echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@
 
 install-script: $(LIBNAME)
 	cp $(LIBNAME) $(BINDIR)
diff --git a/otherlibs/labltk/support/.cvsignore b/otherlibs/labltk/support/.cvsignore
deleted file mode 100644
index 56d9c77a..00000000
--- a/otherlibs/labltk/support/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-*.so
-*.a
diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile
index dd037a2b..26f4c50f 100644
--- a/otherlibs/labltk/support/Makefile
+++ b/otherlibs/labltk/support/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 1999 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.common
 
 all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \
@@ -16,9 +32,10 @@ CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS)
 
 COMPFLAGS=-I $(OTHERS)/win32unix -I $(OTHERS)/unix
 THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads
+TKLDOPTS=$(TK_LINK:%=-ldopt "%")
 
 lib$(LIBNAME).$(A): $(COBJS)
-	$(MKLIB) -o $(LIBNAME) $(COBJS) -ldopt "$(TK_LINK)"
+	$(MKLIB) -o $(LIBNAME) $(COBJS) $(TKLDOPTS)
 
 PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \
     rawwidget.mli widget.mli
diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common
index 56f6fd13..f0aa930d 100644
--- a/otherlibs/labltk/support/Makefile.common
+++ b/otherlibs/labltk/support/Makefile.common
@@ -1,5 +1,21 @@
+#######################################################################
+#                                                                     #
+#                 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 1999 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.          #
+#                                                                     #
+#######################################################################
+
 ## Paths are relative to subdirectories
-## Where you compiled Objective Caml
+## Where you compiled OCaml
 TOPDIR=../../..
 ## Path to the otherlibs subdirectory
 OTHERS=$(TOPDIR)/otherlibs
@@ -10,7 +26,7 @@ include $(TOPDIR)/config/Makefile
 
 INSTALLDIR=$(LIBDIR)/$(LIBNAME)
 
-## Tools from the Objective Caml distribution
+## Tools from the OCaml distribution
 
 CAMLRUN=$(TOPDIR)/boot/ocamlrun
 CAMLC=$(TOPDIR)/ocamlcomp.sh
diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h
index 5be206fa..29452aac 100644
--- a/otherlibs/labltk/support/camltk.h
+++ b/otherlibs/labltk/support/camltk.h
@@ -1,6 +1,6 @@
 /*************************************************************************/
 /*                                                                       */
-/*                Objective Caml LablTk library                          */
+/*                         OCaml LablTk library                          */
 /*                                                                       */
 /*         Francois Rouaix, Francois Pessaux and Jun Furuse              */
 /*               projet Cristal, INRIA Rocquencourt                      */
@@ -33,7 +33,7 @@
 #endif
 
 /* cltkMisc.c */
-/* copy a Caml string to the C heap. Must be deallocated with stat_free */
+/* copy an OCaml string to the C heap. Must be deallocated with stat_free */
 extern char *string_to_c(value s);
 
 /* cltkUtf.c */
@@ -45,7 +45,7 @@ CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */
 extern value copy_string_list(int argc, char **argv);
 
 /* cltkCaml.c */
-/* pointers to Caml values */
+/* pointers to OCaml values */
 extern value *tkerror_exn;
 extern value *handler_code;
 extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,
diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml
index 5b49b19f..635349a3 100644
--- a/otherlibs/labltk/support/camltkwrap.ml
+++ b/otherlibs/labltk/support/camltkwrap.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 module Widget = struct
diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli
index 1af566d2..4fc7e3c1 100644
--- a/otherlibs/labltk/support/camltkwrap.mli
+++ b/otherlibs/labltk/support/camltkwrap.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 module Widget : sig
diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c
index c9bcc80d..9a3d38a5 100644
--- a/otherlibs/labltk/support/cltkCaml.c
+++ b/otherlibs/labltk/support/cltkCaml.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -27,7 +27,7 @@
 value * tkerror_exn = NULL;
 value * handler_code = NULL;
 
-/* The Tcl command for evaluating callback in Caml */
+/* The Tcl command for evaluating callback in OCaml */
 int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,
               int argc, CONST84 char **argv)
 {
@@ -41,7 +41,7 @@ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,
       return TCL_ERROR;
     callback2(*handler_code,Val_int(id),
               copy_string_list(argc - 2,(char **)&argv[2]));
-    /* Never fails (Caml would have raised an exception) */
+    /* Never fails (OCaml would have raised an exception) */
     /* but result may have been set by callback */
     return TCL_OK;
   }
@@ -69,14 +69,14 @@ CAMLprim void tk_error(char *errmsg)
 }
 
 
-/* The initialisation of the C global variables pointing to Caml values
-   must be made accessible from Caml, so that we are sure that it *always*
+/* The initialisation of the C global variables pointing to OCaml values
+   must be made accessible from OCaml, so that we are sure that it *always*
    takes place during loading of the protocol module
  */
 
 CAMLprim value camltk_init(value v)
 {
-  /* Initialize the Caml pointers */
+  /* Initialize the OCaml pointers */
   if (tkerror_exn == NULL)
     tkerror_exn = caml_named_value("tkerror");
   if (handler_code == NULL)
diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c
index 3d9a4c2d..04af209d 100644
--- a/otherlibs/labltk/support/cltkDMain.c
+++ b/otherlibs/labltk/support/cltkDMain.c
@@ -1,6 +1,6 @@
 /*************************************************************************/
 /*                                                                       */
-/*                Objective Caml LablTk library                          */
+/*                         OCaml LablTk library                          */
 /*                                                                       */
 /*         Francois Rouaix, Francois Pessaux and Jun Furuse              */
 /*               projet Cristal, INRIA Rocquencourt                      */
@@ -35,7 +35,7 @@
 
 
 /*
- * Dealing with signals: when a signal handler is defined in Caml,
+ * Dealing with signals: when a signal handler is defined in OCaml,
  * the actual execution of the signal handler upon reception of the
  * signal is delayed until we are sure we are out of the GC.
  * If a signal occurs during the MainLoop, we would have to wait
diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c
index cdd16a91..69ba6d8a 100644
--- a/otherlibs/labltk/support/cltkEval.c
+++ b/otherlibs/labltk/support/cltkEval.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -32,7 +32,7 @@
 /* The Tcl interpretor */
 Tcl_Interp *cltclinterp = NULL;
 
-/* Copy a list of strings from the C heap to Caml */
+/* Copy a list of strings from the C heap to OCaml */
 value copy_string_list(int argc, char **argv)
 {
   CAMLparam0();
@@ -53,7 +53,7 @@ value copy_string_list(int argc, char **argv)
 }
 
 /*
- * Calling Tcl from Caml
+ * Calling Tcl from OCaml
  *   this version works on an arbitrary Tcl command,
  *   and does parsing and substitution
  */
@@ -65,7 +65,7 @@ CAMLprim value camltk_tcl_eval(value str)
   CheckInit();
 
   /* Tcl_Eval may write to its argument, so we take a copy
-   * If the evaluation raises a Caml exception, we have a space
+   * If the evaluation raises an OCaml exception, we have a space
    * leak
    */
   Tcl_ResetResult(cltclinterp);
@@ -84,7 +84,7 @@ CAMLprim value camltk_tcl_eval(value str)
 }
 
 /*
- * Calling Tcl from Caml
+ * Calling Tcl from OCaml
  *   direct call, argument is TkArgs vect
   type TkArgs =
       TkToken of string
@@ -142,7 +142,7 @@ int fill_args (char **argv, int where, value v)
       tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
       fill_args(tmpargv,0,Field(v,0));
       tmpargv[size] = NULL;
-      merged = Tcl_Merge(size,tmpargv);
+      merged = Tcl_Merge(size,(const char *const*)tmpargv);
       for(i = 0; i= 0; i--)
         argv[i+1] = argv[i];
       argv[0] = "unknown";
-      result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
+      result = (*info.proc)(info.clientData,cltclinterp,size+1,(const char**)argv);
     } else { /* ah, it isn't there at all */
       result = TCL_ERROR;
       Tcl_AppendResult(cltclinterp, "Unknown command \"",
diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c
index ad9b4d9e..4507cf69 100644
--- a/otherlibs/labltk/support/cltkEvent.c
+++ b/otherlibs/labltk/support/cltkEvent.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c
index 4fbf9868..b4ebca61 100644
--- a/otherlibs/labltk/support/cltkFile.c
+++ b/otherlibs/labltk/support/cltkFile.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c
index d8d5dd3d..0a0fa17c 100644
--- a/otherlibs/labltk/support/cltkImg.c
+++ b/otherlibs/labltk/support/cltkImg.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 #include 
@@ -90,7 +90,7 @@ camltk_setimgdata_native (value imgname, value pixmap, value x, value y,
     tk_error("no such image");
 #endif
 
-  pib.pixelPtr = String_val(pixmap);
+  pib.pixelPtr = (unsigned char *)String_val(pixmap);
   pib.width = Int_val(w);
   pib.height = Int_val(h);
   pib.pitch = pib.width * 3;
diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c
index eb4617a4..8751334c 100644
--- a/otherlibs/labltk/support/cltkMain.c
+++ b/otherlibs/labltk/support/cltkMain.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -35,7 +35,7 @@
 #endif
 
 /*
- * Dealing with signals: when a signal handler is defined in Caml,
+ * Dealing with signals: when a signal handler is defined in OCaml,
  * the actual execution of the signal handler upon reception of the
  * signal is delayed until we are sure we are out of the GC.
  * If a signal occurs during the MainLoop, we would have to wait
@@ -125,7 +125,7 @@ CAMLprim value camltk_opentk(value argv)
 
         sprintf( argcstr, "%d", argc );
         Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
-        args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
+        args = Tcl_Merge(argc, (const char *const*)tkargv); /* args must be freed by Tcl_Free */
         Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
         Tcl_Free(args);
         stat_free( tkargv );
diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c
index b19713cd..a89ea341 100644
--- a/otherlibs/labltk/support/cltkMisc.c
+++ b/otherlibs/labltk/support/cltkMisc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -35,7 +35,7 @@ CAMLprim value camltk_splitlist (value v)
 
   utf = caml_string_to_tcl(v);
   /* argv is allocated by Tcl, to be freed by us */
-  result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
+  result = Tcl_SplitList(cltclinterp,utf,&argc,(const char ***)&argv);
   switch(result) {
   case TCL_OK:
    { value res = copy_string_list(argc,argv);
@@ -51,7 +51,7 @@ CAMLprim value camltk_splitlist (value v)
   }
 }
 
-/* Copy a Caml string to the C heap. Should deallocate with stat_free */
+/* Copy an OCaml string to the C heap. Should deallocate with stat_free */
 char *string_to_c(value s)
 {
   int l = string_length(s);
diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c
index e0635e85..afebef8e 100644
--- a/otherlibs/labltk/support/cltkTimer.c
+++ b/otherlibs/labltk/support/cltkTimer.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -34,11 +34,11 @@ CAMLprim value camltk_add_timer(value milli, value cbid)
   CheckInit();
   /* look at tkEvent.c , Tk_Token is an int */
   return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc,
-                                       (ClientData) (Int_val(cbid)))));
+                                       (ClientData) (Long_val(cbid)))));
 }
 
 CAMLprim value camltk_rem_timer(value token)
 {
-  Tcl_DeleteTimerHandler((Tcl_TimerToken) Int_val(token));
+  Tcl_DeleteTimerHandler((Tcl_TimerToken) Long_val(token));
   return Val_unit;
 }
diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c
index fd01bd15..448e06a1 100644
--- a/otherlibs/labltk/support/cltkUtf.c
+++ b/otherlibs/labltk/support/cltkUtf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c
index 0411a94c..dcda8a77 100644
--- a/otherlibs/labltk/support/cltkVar.c
+++ b/otherlibs/labltk/support/cltkVar.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -33,13 +33,13 @@ CAMLprim value camltk_getvar(value var)
   CheckInit();
 
   stable_var = string_to_c(var);
-  s = Tcl_GetVar(cltclinterp,stable_var,
-                   TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+  s = (char *)Tcl_GetVar(cltclinterp,stable_var,
+                         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
   stat_free(stable_var);
 
   if (s == NULL)
     tk_error(Tcl_GetStringResult(cltclinterp));
-  else 
+  else
     return(tcl_string_to_caml(s));
 }
 
@@ -51,12 +51,12 @@ CAMLprim value camltk_setvar(value var, value contents)
   CheckInit();
 
   /* SetVar makes a copy of the contents. */
-  /* In case we have write traces in Caml, it's better to make sure that
+  /* In case we have write traces in OCaml, it's better to make sure that
      var doesn't move... */
   stable_var = string_to_c(var);
   utf_contents = caml_string_to_tcl(contents);
-  s = Tcl_SetVar(cltclinterp,stable_var, utf_contents,
-                   TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+  s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents,
+                         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
   stat_free(stable_var);
   if( s == utf_contents ){
     tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!");
diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c
index 4c126b5d..a46860b8 100644
--- a/otherlibs/labltk/support/cltkWait.c
+++ b/otherlibs/labltk/support/cltkWait.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  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 Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
index 846a7519..ae1cc261 100644
--- a/otherlibs/labltk/support/fileevent.ml
+++ b/otherlibs/labltk/support/fileevent.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli
index 34760f0c..f5468ca5 100644
--- a/otherlibs/labltk/support/fileevent.mli
+++ b/otherlibs/labltk/support/fileevent.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
index 26b97c0b..28cb4737 100644
--- a/otherlibs/labltk/support/protocol.ml
+++ b/otherlibs/labltk/support/protocol.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli
index 9b5ae393..1ce6718a 100644
--- a/otherlibs/labltk/support/protocol.mli
+++ b/otherlibs/labltk/support/protocol.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml
index 99b1dce1..f216df72 100644
--- a/otherlibs/labltk/support/rawwidget.ml
+++ b/otherlibs/labltk/support/rawwidget.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli
index 4eda7311..e9f82ef2 100644
--- a/otherlibs/labltk/support/rawwidget.mli
+++ b/otherlibs/labltk/support/rawwidget.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml
index 51eae853..44349c05 100644
--- a/otherlibs/labltk/support/slave.ml
+++ b/otherlibs/labltk/support/slave.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml
index fa650e8a..7d019967 100644
--- a/otherlibs/labltk/support/support.ml
+++ b/otherlibs/labltk/support/support.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli
index 95a2255c..fe30208a 100644
--- a/otherlibs/labltk/support/support.mli
+++ b/otherlibs/labltk/support/support.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
index ad9033d4..4e17a008 100644
--- a/otherlibs/labltk/support/textvariable.ml
+++ b/otherlibs/labltk/support/textvariable.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli
index dfa511a2..f18f6cc8 100644
--- a/otherlibs/labltk/support/textvariable.mli
+++ b/otherlibs/labltk/support/textvariable.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
index a6ef8c29..d5bd176a 100644
--- a/otherlibs/labltk/support/timer.ml
+++ b/otherlibs/labltk/support/timer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli
index a45e1c9d..4b31668c 100644
--- a/otherlibs/labltk/support/timer.mli
+++ b/otherlibs/labltk/support/timer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml
index ecdf6146..4ae36685 100644
--- a/otherlibs/labltk/support/tkthread.ml
+++ b/otherlibs/labltk/support/tkthread.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*              LablTk, Tcl/Tk interface of Objective Caml             *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*         Jacques Garrigue, Nagoya University Mathematics Dept.       *)
 (*                                                                     *)
@@ -8,7 +8,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli
index 4f20e614..2bc104da 100644
--- a/otherlibs/labltk/support/tkthread.mli
+++ b/otherlibs/labltk/support/tkthread.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*              LablTk, Tcl/Tk interface of Objective Caml             *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*         Jacques Garrigue, Nagoya University Mathematics Dept.       *)
 (*                                                                     *)
@@ -8,7 +8,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml
index 97a0b0eb..34f6908d 100644
--- a/otherlibs/labltk/support/tkwait.ml
+++ b/otherlibs/labltk/support/tkwait.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml
index 65e0d26a..083e4b96 100644
--- a/otherlibs/labltk/support/widget.ml
+++ b/otherlibs/labltk/support/widget.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli
index f9c83278..7761f2f2 100644
--- a/otherlibs/labltk/support/widget.mli
+++ b/otherlibs/labltk/support/widget.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  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 Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
diff --git a/otherlibs/num/.cvsignore b/otherlibs/num/.cvsignore
deleted file mode 100644
index 02023cba..00000000
--- a/otherlibs/num/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-libnums.x
-*.c.x
-so_locations
-*.so
-*.a
diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
index 1e783ec0..2013ac35 100644
--- a/otherlibs/num/.depend
+++ b/otherlibs/num/.depend
@@ -1,11 +1,9 @@
 bng.o: bng.c bng.h ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/compatibility.h bng_amd64.c \
   bng_digit.c
-bng_alpha.o: bng_alpha.c
 bng_amd64.o: bng_amd64.c
 bng_digit.o: bng_digit.c
 bng_ia32.o: bng_ia32.c
-bng_mips.o: bng_mips.c
 bng_ppc.o: bng_ppc.c
 bng_sparc.o: bng_sparc.c
 nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \
@@ -13,28 +11,28 @@ nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/mlvalues.h \
   ../../byterun/config.h ../../byterun/custom.h ../../byterun/intext.h \
-  ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
+  ../../byterun/io.h ../../byterun/fail.h ../../byterun/hash.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h \
   ../../byterun/mlvalues.h bng.h nat.h
-arith_flags.cmi:
-arith_status.cmi:
-big_int.cmi: nat.cmi
-int_misc.cmi:
-nat.cmi:
-num.cmi: ratio.cmi nat.cmi big_int.cmi
-ratio.cmi: nat.cmi big_int.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: nat.cmi int_misc.cmi big_int.cmi
-big_int.cmx: nat.cmx int_misc.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
-num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
-ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
-ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+arith_flags.cmi :
+arith_status.cmi :
+big_int.cmi : nat.cmi
+int_misc.cmi :
+nat.cmi :
+num.cmi : ratio.cmi nat.cmi big_int.cmi
+ratio.cmi : nat.cmi big_int.cmi
+arith_flags.cmo : arith_flags.cmi
+arith_flags.cmx : arith_flags.cmi
+arith_status.cmo : arith_flags.cmi arith_status.cmi
+arith_status.cmx : arith_flags.cmx arith_status.cmi
+big_int.cmo : nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx : nat.cmx int_misc.cmx big_int.cmi
+int_misc.cmo : int_misc.cmi
+int_misc.cmx : int_misc.cmi
+nat.cmo : int_misc.cmi nat.cmi
+nat.cmx : int_misc.cmx nat.cmi
+num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
index 0a4349e8..e5bcb97c 100644
--- a/otherlibs/num/Makefile
+++ b/otherlibs/num/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,7 +28,7 @@ clean::
 	rm -f *~
 
 bng.$(O): bng.h bng_digit.c \
-       bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
 
 depend:
 	gcc -MM $(CFLAGS) *.c > .depend
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
index 16103b2b..4ac69c7c 100644
--- a/otherlibs/num/Makefile.nt
+++ b/otherlibs/num/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,7 +28,7 @@ clean::
 	rm -f *~
 
 bng.$(O): bng.h bng_digit.c \
-       bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
 
 depend:
 	sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml
index 00e2813e..048d4f8d 100644
--- a/otherlibs/num/arith_flags.ml
+++ b/otherlibs/num/arith_flags.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli
index 36160edb..65394243 100644
--- a/otherlibs/num/arith_flags.mli
+++ b/otherlibs/num/arith_flags.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml
index 8b6fa9f7..0f9deb36 100644
--- a/otherlibs/num/arith_status.ml
+++ b/otherlibs/num/arith_status.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
index 121b4d57..170e8cd4 100644
--- a/otherlibs/num/arith_status.mli
+++ b/otherlibs/num/arith_status.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
index b96b8e1f..34de4b12 100644
--- a/otherlibs/num/big_int.ml
+++ b/otherlibs/num/big_int.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
index 2ac7b7eb..46621f94 100644
--- a/otherlibs/num/big_int.mli
+++ b/otherlibs/num/big_int.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/bignum/.cvsignore b/otherlibs/num/bignum/.cvsignore
deleted file mode 100644
index c76baffd..00000000
--- a/otherlibs/num/bignum/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-libbignum.x
diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
index 74502470..5bbedb0b 100644
--- a/otherlibs/num/bng.c
+++ b/otherlibs/num/bng.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h
index 6d12c87c..19f2e2b9 100644
--- a/otherlibs/num/bng.h
+++ b/otherlibs/num/bng.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/bng_alpha.c b/otherlibs/num/bng_alpha.c
deleted file mode 100644
index 5bf964b5..00000000
--- a/otherlibs/num/bng_alpha.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 2003 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the Alpha architecture. */
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mulq %2, %3, %0 \n\t"                                                \
-      "umulh %2, %3, %1"                                                    \
-      : "=&r" (resl), "=r" (resh)                                           \
-      : "r" (arg1), "r" (arg2))
diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
index e829eef2..ecf9f253 100644
--- a/otherlibs/num/bng_amd64.c
+++ b/otherlibs/num/bng_amd64.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
index 168b44ad..e429197c 100644
--- a/otherlibs/num/bng_digit.c
+++ b/otherlibs/num/bng_digit.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c
index bbca8e9d..b4981cd4 100644
--- a/otherlibs/num/bng_ia32.c
+++ b/otherlibs/num/bng_ia32.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c
deleted file mode 100644
index f246843c..00000000
--- a/otherlibs/num/bng_mips.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 2003 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the MIPS architecture. */
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("multu %2, %3 \n\t"                                                   \
-      "mflo %0 \n\t"                                                        \
-      "mfhi %1"                                                             \
-      : "=r" (resl), "=r" (resh)                                            \
-      : "r" (arg1), "r" (arg2))
diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c
index 32d573cd..6bbf108e 100644
--- a/otherlibs/num/bng_ppc.c
+++ b/otherlibs/num/bng_ppc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -91,4 +91,4 @@
       "mulhwu %1, %2, %3"                                                   \
       : "=&r" (resl), "=r" (resh)                                           \
       : "r" (arg1), "r" (arg2))
-#endif
\ No newline at end of file
+#endif
diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
index 934c0b2f..4e46a316 100644
--- a/otherlibs/num/bng_sparc.c
+++ b/otherlibs/num/bng_sparc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml
index b7eb4c67..99713b91 100644
--- a/otherlibs/num/int_misc.ml
+++ b/otherlibs/num/int_misc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli
index 28bb335b..7f465c5a 100644
--- a/otherlibs/num/int_misc.mli
+++ b/otherlibs/num/int_misc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h
index 7f67b916..62c7ac98 100644
--- a/otherlibs/num/nat.h
+++ b/otherlibs/num/nat.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
index cda80d5d..44742a21 100644
--- a/otherlibs/num/nat.ml
+++ b/otherlibs/num/nat.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli
index 3b32ac8d..39f1c590 100644
--- a/otherlibs/num/nat.mli
+++ b/otherlibs/num/nat.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
index cffe1237..52158516 100644
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -18,6 +18,7 @@
 #include "custom.h"
 #include "intext.h"
 #include "fail.h"
+#include "hash.h"
 #include "memory.h"
 #include "mlvalues.h"
 
@@ -26,6 +27,7 @@
 
 /* Stub code for the Nat module. */
 
+static intnat hash_nat(value);
 static void serialize_nat(value, uintnat *, uintnat *);
 static uintnat deserialize_nat(void * dst);
 
@@ -33,9 +35,10 @@ static struct custom_operations nat_operations = {
   "_nat",
   custom_finalize_default,
   custom_compare_default,
-  custom_hash_default,
+  hash_nat,
   serialize_nat,
-  deserialize_nat
+  deserialize_nat,
+  custom_compare_ext_default
 };
 
 CAMLprim value initialize_nat(value unit)
@@ -389,3 +392,28 @@ static uintnat deserialize_nat(void * dst)
 #endif
   return len * 4;
 }
+
+static intnat hash_nat(value v)
+{
+  bngsize len, i;
+  uint32 h;
+
+  len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1);
+  h = 0;
+  for (i = 0; i < len; i++) {
+    bngdigit d = Digit_val(v, i);
+#ifdef ARCH_SIXTYFOUR
+    /* Mix the two 32-bit halves as if we were on a 32-bit platform,
+       namely low 32 bits first, then high 32 bits.
+       Also, ignore final 32 bits if they are zero. */
+    h = caml_hash_mix_uint32(h, (uint32) d);
+    d = d >> 32;
+    if (d == 0 && i + 1 == len) break;
+    h = caml_hash_mix_uint32(h, (uint32) d);
+#else
+    h = caml_hash_mix_uint32(h, d);
+#endif
+  }
+  return h;
+}
+
diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
index 52fe8cc0..4ede5ee4 100644
--- a/otherlibs/num/num.ml
+++ b/otherlibs/num/num.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
index 8bf3d4e6..17733384 100644
--- a/otherlibs/num/num.mli
+++ b/otherlibs/num/num.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -155,7 +155,9 @@ val approx_num_exp : int -> num -> string
    first argument is the number of digits in the mantissa. *)
 
 val num_of_string : string -> num
-(** Convert a string to a number. *)
+(** Convert a string to a number.
+   Raise [Failure "num_of_string"] if the given string is not
+   a valid representation of an integer *)
 
 (** {6 Coercions between numerical types} *)
 
diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml
index 7885df15..fe0170f2 100644
--- a/otherlibs/num/ratio.ml
+++ b/otherlibs/num/ratio.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli
index 12621f08..408aea9b 100644
--- a/otherlibs/num/ratio.mli
+++ b/otherlibs/num/ratio.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -13,7 +13,10 @@
 
 (* $Id$ *)
 
-(* Module [Ratio]: operations on rational numbers *)
+(** Operation on rational numbers.
+
+    This module is used to support the implementation of {!Num} and
+    should not be called directly. *)
 
 open Nat
 open Big_int
@@ -25,6 +28,8 @@ open Big_int
 
 type ratio
 
+(**/**)
+
 val null_denominator : ratio -> bool
 val numerator_ratio : ratio -> big_int
 val denominator_ratio : ratio -> big_int
@@ -32,8 +37,9 @@ val sign_ratio : ratio -> int
 val normalize_ratio : ratio -> ratio
 val cautious_normalize_ratio : ratio -> ratio
 val cautious_normalize_ratio_when_printing : ratio -> ratio
-val create_ratio : big_int -> big_int -> ratio
+val create_ratio : big_int -> big_int -> ratio (* assumes nothing *)
 val create_normalized_ratio : big_int -> big_int -> ratio
+                              (* assumes normalized argument *)
 val is_normalized_ratio : ratio -> bool
 val report_sign_ratio : ratio -> big_int -> big_int
 val abs_ratio : ratio -> ratio
diff --git a/otherlibs/str/.cvsignore b/otherlibs/str/.cvsignore
deleted file mode 100644
index 49c78e58..00000000
--- a/otherlibs/str/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-libstr.x
-*.c.x
-so_locations
-*.so
-*.a
diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
index df6eb9af..5be8377c 100644
--- a/otherlibs/str/.depend
+++ b/otherlibs/str/.depend
@@ -4,6 +4,6 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \
   ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h
-str.cmi:
-str.cmo: str.cmi
-str.cmx: str.cmi
+str.cmi :
+str.cmo : str.cmi
+str.cmx : str.cmi
diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
index b6c16a07..e36000e4 100644
--- a/otherlibs/str/Makefile
+++ b/otherlibs/str/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
index 5aeff80b..b0420b39 100644
--- a/otherlibs/str/Makefile.nt
+++ b/otherlibs/str/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index f3f760ac..5d53168f 100644
--- a/otherlibs/str/str.ml
+++ b/otherlibs/str/str.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli
index b63faf84..a4d65b6a 100644
--- a/otherlibs/str/str.mli
+++ b/otherlibs/str/str.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c
index b8d53ff8..fc2f46f8 100644
--- a/otherlibs/str/strstubs.c
+++ b/otherlibs/str/strstubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */
diff --git a/otherlibs/systhreads/.cvsignore b/otherlibs/systhreads/.cvsignore
deleted file mode 100644
index 1f1e6a38..00000000
--- a/otherlibs/systhreads/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-*.x
-thread.ml
-so_locations
-*.so
-*.a
diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
index 9c6889b7..85add2e5 100644
--- a/otherlibs/systhreads/.depend
+++ b/otherlibs/systhreads/.depend
@@ -9,18 +9,18 @@ st_stubs.o: st_stubs.c ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \
   ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \
   ../../byterun/sys.h threads.h st_posix.h
-condition.cmi: mutex.cmi
-event.cmi:
-mutex.cmi:
-thread.cmi:
-threadUnix.cmi:
-condition.cmo: mutex.cmi condition.cmi
-condition.cmx: mutex.cmx condition.cmi
-event.cmo: mutex.cmi condition.cmi event.cmi
-event.cmx: mutex.cmx condition.cmx event.cmi
-mutex.cmo: mutex.cmi
-mutex.cmx: mutex.cmi
-thread.cmo: thread.cmi
-thread.cmx: thread.cmi
-threadUnix.cmo: thread.cmi threadUnix.cmi
-threadUnix.cmx: thread.cmx threadUnix.cmi
+condition.cmi : mutex.cmi
+event.cmi :
+mutex.cmi :
+thread.cmi :
+threadUnix.cmi :
+condition.cmo : mutex.cmi condition.cmi
+condition.cmx : mutex.cmx condition.cmi
+event.cmo : mutex.cmi condition.cmi event.cmi
+event.cmx : mutex.cmx condition.cmx event.cmi
+mutex.cmo : mutex.cmi
+mutex.cmx : mutex.cmi
+thread.cmo : thread.cmi
+thread.cmx : thread.cmi
+threadUnix.cmo : thread.cmi threadUnix.cmi
+threadUnix.cmx : thread.cmx threadUnix.cmi
diff --git a/otherlibs/systhreads/.ignore b/otherlibs/systhreads/.ignore
new file mode 100644
index 00000000..71702b88
--- /dev/null
+++ b/otherlibs/systhreads/.ignore
@@ -0,0 +1 @@
+thread.ml
diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
index f5c80c0e..fbdd8994 100644
--- a/otherlibs/systhreads/Makefile
+++ b/otherlibs/systhreads/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
index 8c559e0b..8cc9dd26 100644
--- a/otherlibs/systhreads/Makefile.nt
+++ b/otherlibs/systhreads/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/systhreads/condition.ml b/otherlibs/systhreads/condition.ml
index 6549c642..6bdac6a3 100644
--- a/otherlibs/systhreads/condition.ml
+++ b/otherlibs/systhreads/condition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Caml Special Light                          *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli
index 5bc9d674..d13b30d8 100644
--- a/otherlibs/systhreads/condition.mli
+++ b/otherlibs/systhreads/condition.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml
index 74f457b0..ff137e98 100644
--- a/otherlibs/systhreads/event.ml
+++ b/otherlibs/systhreads/event.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli
index 08d6b0bf..11842e5a 100644
--- a/otherlibs/systhreads/event.mli
+++ b/otherlibs/systhreads/event.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/mutex.ml b/otherlibs/systhreads/mutex.ml
index 4e108f4a..5e9cc886 100644
--- a/otherlibs/systhreads/mutex.ml
+++ b/otherlibs/systhreads/mutex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Caml Special Light                          *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt           *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/mutex.mli b/otherlibs/systhreads/mutex.mli
index b1fe1413..844d4e5d 100644
--- a/otherlibs/systhreads/mutex.mli
+++ b/otherlibs/systhreads/mutex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
index 708a4abf..070a4496 100644
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -254,7 +254,7 @@ static int st_event_create(st_event * res)
   rc = pthread_mutex_init(&e->lock, NULL);
   if (rc != 0) { free(e); return rc; }
   rc = pthread_cond_init(&e->triggered, NULL);
-  if (rc != 0) { free(e); return rc; }
+  if (rc != 0) { pthread_mutex_destroy(&e->lock); free(e); return rc; }
   e->status = 0;
   *res = e;
   return 0;
@@ -320,11 +320,8 @@ static void * caml_thread_tick(void * arg)
 {
   struct timeval timeout;
   sigset_t mask;
-#ifdef __linux__
-  int tickcount = 0;
-#endif
 
-  /* Block all signals so that we don't try to execute a Caml signal handler */
+  /* Block all signals so that we don't try to execute an OCaml signal handler*/
   sigfillset(&mask);
   pthread_sigmask(SIG_BLOCK, &mask, NULL);
   /* Allow async cancellation */
@@ -339,18 +336,6 @@ static void * caml_thread_tick(void * arg)
      go through caml_handle_signal(), just record signal delivery via
      caml_record_signal(). */
     caml_record_signal(SIGPREEMPTION);
-#ifdef __linux__
-    /* Hack around LinuxThreads' non-standard signal handling:
-       if program is killed on a signal, e.g. SIGINT, the current
-       thread will not die on this signal (because of the signal blocking
-       above).  Hence, periodically check that the thread manager (our
-       parent process) still exists. */
-    tickcount++;
-    if (tickcount >= 2000 / Thread_timeout) { /* every 2 secs approx */
-      tickcount = 0;
-      if (getppid() == 1) pthread_exit(NULL);
-    }
-#endif
   }
   return NULL;                  /* prevents compiler warning */
 }
diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index 55e35d41..9b2493a1 100644
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -94,7 +94,7 @@ static caml_thread_t all_threads = NULL;
 /* The descriptor for the currently executing thread */
 static caml_thread_t curr_thread = NULL;
 
-/* The master lock protecting the Caml runtime system */
+/* The master lock protecting the OCaml runtime system */
 static st_masterlock caml_master_lock;
 
 /* Whether the ``tick'' thread is already running */
@@ -344,7 +344,10 @@ static value caml_thread_new_descriptor(value clos)
 
 static void caml_thread_remove_info(caml_thread_t th)
 {
-  if (th->next == th) all_threads = NULL; /* last Caml thread exiting */
+  if (th->next == th)
+    all_threads = NULL; /* last OCaml thread exiting */
+  else if (all_threads == th)
+    all_threads = th->next;     /* PR#5295 */
   th->next->prev = th->prev;
   th->prev->next = th->next;
 #ifndef NATIVE_CODE
@@ -646,7 +649,7 @@ CAMLprim value caml_thread_exit(value unit)   /* ML */
 #endif
   caml_thread_stop();
   if (exit_buf != NULL) {
-    /* Native-code and (main thread or thread created by Caml) */
+    /* Native-code and (main thread or thread created by OCaml) */
     siglongjmp(exit_buf->buf, 1);
   } else {
     /* Bytecode, or thread created from C */
@@ -685,18 +688,23 @@ static void caml_mutex_finalize(value wrapper)
   st_mutex_destroy(Mutex_val(wrapper));
 }
 
-static int caml_mutex_condition_compare(value wrapper1, value wrapper2)
+static int caml_mutex_compare(value wrapper1, value wrapper2)
 {
   st_mutex mut1 = Mutex_val(wrapper1);
   st_mutex mut2 = Mutex_val(wrapper2);
   return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1;
 }
 
+static intnat caml_mutex_hash(value wrapper)
+{
+  return (intnat) (Mutex_val(wrapper));
+}
+
 static struct custom_operations caml_mutex_ops = {
   "_mutex",
   caml_mutex_finalize,
-  caml_mutex_condition_compare,
-  custom_hash_default,
+  caml_mutex_compare,
+  caml_mutex_hash,
   custom_serialize_default,
   custom_deserialize_default
 };
@@ -759,13 +767,26 @@ static void caml_condition_finalize(value wrapper)
   st_condvar_destroy(Condition_val(wrapper));
 }
 
+static int caml_condition_compare(value wrapper1, value wrapper2)
+{
+  st_condvar cond1 = Condition_val(wrapper1);
+  st_condvar cond2 = Condition_val(wrapper2);
+  return cond1 == cond2 ? 0 : cond1 < cond2 ? -1 : 1;
+}
+
+static intnat caml_condition_hash(value wrapper)
+{
+  return (intnat) (Condition_val(wrapper));
+}
+
 static struct custom_operations caml_condition_ops = {
   "_condition",
   caml_condition_finalize,
-  caml_mutex_condition_compare,
-  custom_hash_default,
+  caml_condition_compare,
+  caml_condition_hash,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 CAMLprim value caml_condition_new(value unit)        /* ML */
@@ -818,13 +839,21 @@ static void caml_threadstatus_finalize(value wrapper)
   st_event_destroy(Threadstatus_val(wrapper));
 }
 
+static int caml_threadstatus_compare(value wrapper1, value wrapper2)
+{
+  st_event ts1 = Threadstatus_val(wrapper1);
+  st_event ts2 = Threadstatus_val(wrapper2);
+  return ts1 == ts2 ? 0 : ts1 < ts2 ? -1 : 1;
+}
+
 static struct custom_operations caml_threadstatus_ops = {
   "_threadstatus",
   caml_threadstatus_finalize,
-  custom_compare_default,
+  caml_threadstatus_compare,
   custom_hash_default,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 static value caml_threadstatus_new (void)
diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h
index d4ad98c0..da602b7f 100644
--- a/otherlibs/systhreads/st_win32.h
+++ b/otherlibs/systhreads/st_win32.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -15,6 +15,7 @@
 
 /* Win32 implementation of the "st" interface */
 
+#define _WIN32_WINNT 0x0400
 #include 
 #include 
 #include 
diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml
index b0f01dad..ee01c955 100644
--- a/otherlibs/systhreads/thread.ml
+++ b/otherlibs/systhreads/thread.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Objective Caml                              *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -63,7 +63,7 @@ let _ =
   at_exit
     (fun () ->
         thread_cleanup();
-        (* In case of DLL-embedded Ocaml the preempt_signal handler
+        (* In case of DLL-embedded OCaml the preempt_signal handler
            will point to nowhere after DLL unloading and an accidental
            preempt_signal will crash the main program. So restore the
            default handler. *)
diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli
index 3c2fc01b..42d18e63 100644
--- a/otherlibs/systhreads/thread.mli
+++ b/otherlibs/systhreads/thread.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Objective Caml                              *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml
index 71855ec6..d4b6fd59 100644
--- a/otherlibs/systhreads/threadUnix.ml
+++ b/otherlibs/systhreads/threadUnix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli
index c05346fe..9c7e76e5 100644
--- a/otherlibs/systhreads/threadUnix.mli
+++ b/otherlibs/systhreads/threadUnix.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/systhreads/threads.h b/otherlibs/systhreads/threads.h
index 3675e69f..ff140cd5 100644
--- a/otherlibs/systhreads/threads.h
+++ b/otherlibs/systhreads/threads.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -21,22 +21,22 @@ CAMLextern void caml_leave_blocking_section (void);
 #define caml_acquire_runtime_system caml_leave_blocking_section
 #define caml_release_runtime_system caml_enter_blocking_section
 
-/* Manage the master lock around the Caml run-time system.
-   Only one thread at a time can execute Caml compiled code or
-   Caml run-time system functions.
+/* Manage the master lock around the OCaml run-time system.
+   Only one thread at a time can execute OCaml compiled code or
+   OCaml run-time system functions.
 
-   When Caml calls a C function, the current thread holds the master
+   When OCaml calls a C function, the current thread holds the master
    lock.  The C function can release it by calling
-   [caml_release_runtime_system].  Then, another thread can execute Caml
-   code.  However, the calling thread must not access any Caml data,
-   nor call any runtime system function, nor call back into Caml.
+   [caml_release_runtime_system].  Then, another thread can execute OCaml
+   code.  However, the calling thread must not access any OCaml data,
+   nor call any runtime system function, nor call back into OCaml.
 
-   Before returning to its Caml caller, or accessing Caml data,
+   Before returning to its OCaml caller, or accessing OCaml data,
    or call runtime system functions, the current thread must
    re-acquire the master lock by calling [caml_acquire_runtime_system].
 
-   Symmetrically, if a C function (not called from Caml) wishes to
-   call back into Caml code, it should invoke [caml_acquire_runtime_system]
+   Symmetrically, if a C function (not called from OCaml) wishes to
+   call back into OCaml code, it should invoke [caml_acquire_runtime_system]
    first, then do the callback, then invoke [caml_release_runtime_system].
 
    For historical reasons, alternate names can be used:
@@ -49,9 +49,9 @@ CAMLextern void caml_leave_blocking_section (void);
 CAMLextern int caml_c_thread_register(void);
 CAMLextern int caml_c_thread_unregister(void);
 
-/* If a thread is created by C code (instead of by Caml itself),
-   it must be registered with the Caml runtime system before
-   being able to call back into Caml code or use other runtime system
+/* If a thread is created by C code (instead of by OCaml itself),
+   it must be registered with the OCaml runtime system before
+   being able to call back into OCaml code or use other runtime system
    functions.  Just call [caml_c_thread_register] once.
    Before the thread finishes, it must call [caml_c_thread_unregister].
    Both functions return 1 on success, 0 on error.
diff --git a/otherlibs/threads/.cvsignore b/otherlibs/threads/.cvsignore
deleted file mode 100644
index c17596c7..00000000
--- a/otherlibs/threads/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-marshal.mli
-pervasives.mli
-unix.mli
-*.so
-*.a
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index 7ce4479a..bc03050b 100644
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -9,24 +9,27 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \
   ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \
   ../../byterun/sys.h
-condition.cmi: mutex.cmi
-event.cmi:
-mutex.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.cmo
-marshal.cmx: pervasives.cmx
-mutex.cmo: thread.cmi mutex.cmi
-mutex.cmx: thread.cmx mutex.cmi
-pervasives.cmo: unix.cmo
-pervasives.cmx: unix.cmx
-thread.cmo: unix.cmo thread.cmi
-thread.cmx: unix.cmx thread.cmi
-threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi
-threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi
-unix.cmo:
-unix.cmx:
+condition.cmi : mutex.cmi
+event.cmi :
+marshal.cmi :
+mutex.cmi :
+pervasives.cmi :
+thread.cmi : unix.cmi
+threadUnix.cmi : unix.cmi
+unix.cmi :
+condition.cmo : thread.cmi mutex.cmi condition.cmi
+condition.cmx : thread.cmx mutex.cmx condition.cmi
+event.cmo : mutex.cmi condition.cmi event.cmi
+event.cmx : mutex.cmx condition.cmx event.cmi
+marshal.cmo : pervasives.cmi marshal.cmi
+marshal.cmx : pervasives.cmx marshal.cmi
+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
+thread.cmx : unix.cmx thread.cmi
+threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi
+threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
+unix.cmo : unix.cmi
+unix.cmx : unix.cmi
diff --git a/otherlibs/threads/.ignore b/otherlibs/threads/.ignore
new file mode 100644
index 00000000..fb2df562
--- /dev/null
+++ b/otherlibs/threads/.ignore
@@ -0,0 +1,3 @@
+marshal.mli
+pervasives.mli
+unix.mli
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index 0e6ef86f..3354a275 100644
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml
index e012a86e..ee687a85 100644
--- a/otherlibs/threads/condition.ml
+++ b/otherlibs/threads/condition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli
index 5bc9d674..d13b30d8 100644
--- a/otherlibs/threads/condition.mli
+++ b/otherlibs/threads/condition.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml
index 74f457b0..ff137e98 100644
--- a/otherlibs/threads/event.ml
+++ b/otherlibs/threads/event.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli
index 08d6b0bf..11842e5a 100644
--- a/otherlibs/threads/event.mli
+++ b/otherlibs/threads/event.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml
index d31a667d..6f2bcfed 100644
--- a/otherlibs/threads/marshal.ml
+++ b/otherlibs/threads/marshal.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml
index f0f6845b..12e3f534 100644
--- a/otherlibs/threads/mutex.ml
+++ b/otherlibs/threads/mutex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli
index b1fe1413..844d4e5d 100644
--- a/otherlibs/threads/mutex.mli
+++ b/otherlibs/threads/mutex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 08115a2f..f83a1cf0 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -94,6 +94,7 @@ 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 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"
@@ -107,6 +108,7 @@ 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 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 c73ac67e..3f519790 100644
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml
index 723669a3..f4bbd8a5 100644
--- a/otherlibs/threads/thread.ml
+++ b/otherlibs/threads/thread.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
index 9577a54e..e97e55ab 100644
--- a/otherlibs/threads/thread.mli
+++ b/otherlibs/threads/thread.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml
index 66a3704c..bd4181b9 100644
--- a/otherlibs/threads/threadUnix.ml
+++ b/otherlibs/threads/threadUnix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
index 1b4dde29..22ed9330 100644
--- a/otherlibs/threads/threadUnix.mli
+++ b/otherlibs/threads/threadUnix.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
index 5a8bb697..609c098a 100644
--- a/otherlibs/threads/unix.ml
+++ b/otherlibs/threads/unix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -192,6 +192,7 @@ type open_flag =
   | O_DSYNC
   | O_SYNC
   | O_RSYNC
+  | O_SHARE_DELETE
 
 type file_perm = int
 
diff --git a/otherlibs/unix/.cvsignore b/otherlibs/unix/.cvsignore
deleted file mode 100644
index 29fea472..00000000
--- a/otherlibs/unix/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-so_locations
-*.so
-*.a
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index 42dbc3c0..ef8832f9 100644
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -449,9 +449,9 @@ write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h \
   ../../byterun/signals.h unixsupport.h
-unix.cmi:
-unixLabels.cmi: unix.cmi
-unix.cmo: unix.cmi
-unix.cmx: unix.cmi
-unixLabels.cmo: unix.cmi unixLabels.cmi
-unixLabels.cmx: unix.cmx unixLabels.cmi
+unix.cmi :
+unixLabels.cmi : unix.cmi
+unix.cmo : unix.cmi
+unix.cmx : unix.cmi
+unixLabels.cmo : unix.cmi unixLabels.cmi
+unixLabels.cmx : unix.cmx unixLabels.cmi
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index be723496..5a11b5c2 100644
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c
index a6e80f06..7b2688f0 100644
--- a/otherlibs/unix/accept.c
+++ b/otherlibs/unix/accept.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
index 0c0c5fc1..813c0634 100644
--- a/otherlibs/unix/access.c
+++ b/otherlibs/unix/access.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c
index 6947d66f..217397b5 100644
--- a/otherlibs/unix/addrofstr.c
+++ b/otherlibs/unix/addrofstr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c
index 55e4d6cf..6275e255 100644
--- a/otherlibs/unix/alarm.c
+++ b/otherlibs/unix/alarm.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c
index 85cf1d28..a6999a9f 100644
--- a/otherlibs/unix/bind.c
+++ b/otherlibs/unix/bind.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c
index 7901eca0..2788c505 100644
--- a/otherlibs/unix/chdir.c
+++ b/otherlibs/unix/chdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c
index dff83722..f01d7e85 100644
--- a/otherlibs/unix/chmod.c
+++ b/otherlibs/unix/chmod.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c
index bfd16400..72002e93 100644
--- a/otherlibs/unix/chown.c
+++ b/otherlibs/unix/chown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c
index 24f49877..879d0662 100644
--- a/otherlibs/unix/chroot.c
+++ b/otherlibs/unix/chroot.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c
index 27e1937d..0aaf74bd 100644
--- a/otherlibs/unix/close.c
+++ b/otherlibs/unix/close.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c
index b2fd5135..a6440efa 100644
--- a/otherlibs/unix/closedir.c
+++ b/otherlibs/unix/closedir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c
index 669c347f..a17a89ff 100644
--- a/otherlibs/unix/connect.c
+++ b/otherlibs/unix/connect.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c
index 9035160d..8ce4d3f0 100644
--- a/otherlibs/unix/cst2constr.c
+++ b/otherlibs/unix/cst2constr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h
index 3cb1c118..e1c61a0c 100644
--- a/otherlibs/unix/cst2constr.h
+++ b/otherlibs/unix/cst2constr.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c
index 0e37914d..5c83b59e 100644
--- a/otherlibs/unix/cstringv.c
+++ b/otherlibs/unix/cstringv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c
index 5935d0b4..f78d9369 100644
--- a/otherlibs/unix/dup.c
+++ b/otherlibs/unix/dup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c
index beb98713..41231589 100644
--- a/otherlibs/unix/dup2.c
+++ b/otherlibs/unix/dup2.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c
index 1df842c5..52e43ab7 100644
--- a/otherlibs/unix/envir.c
+++ b/otherlibs/unix/envir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -22,5 +22,9 @@ extern char ** environ;
 
 CAMLprim value unix_environment(value unit)
 {
-  return copy_string_array((const char**)environ);
+  if (environ != NULL) {
+    return copy_string_array((const char**)environ);
+  } else {
+    return Atom(0);
+  }
 }
diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c
index ae8793e1..6cf82d63 100644
--- a/otherlibs/unix/errmsg.c
+++ b/otherlibs/unix/errmsg.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c
index bc0330b3..51eabc71 100644
--- a/otherlibs/unix/execv.c
+++ b/otherlibs/unix/execv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c
index 4d29fb55..00ab6af4 100644
--- a/otherlibs/unix/execve.c
+++ b/otherlibs/unix/execve.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c
index 6d03a29e..db77d413 100644
--- a/otherlibs/unix/execvp.c
+++ b/otherlibs/unix/execvp.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c
index 8f1df6d5..88fc0125 100644
--- a/otherlibs/unix/exit.c
+++ b/otherlibs/unix/exit.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c
index a90de6ef..b2d49dcd 100644
--- a/otherlibs/unix/fchmod.c
+++ b/otherlibs/unix/fchmod.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c
index 29683a5c..e2c934ae 100644
--- a/otherlibs/unix/fchown.c
+++ b/otherlibs/unix/fchown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c
index a0891b2c..58f7df75 100644
--- a/otherlibs/unix/fcntl.c
+++ b/otherlibs/unix/fcntl.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
index 74ec6294..80b44355 100644
--- a/otherlibs/unix/fork.c
+++ b/otherlibs/unix/fork.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
index 661640e3..5eaa166f 100644
--- a/otherlibs/unix/ftruncate.c
+++ b/otherlibs/unix/ftruncate.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c
index adc54998..34cf8280 100644
--- a/otherlibs/unix/getaddrinfo.c
+++ b/otherlibs/unix/getaddrinfo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c
index 7c735b68..f3ff9711 100644
--- a/otherlibs/unix/getcwd.c
+++ b/otherlibs/unix/getcwd.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c
index 02beaf12..9c6097ef 100644
--- a/otherlibs/unix/getegid.c
+++ b/otherlibs/unix/getegid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c
index 7c9f660a..55e07638 100644
--- a/otherlibs/unix/geteuid.c
+++ b/otherlibs/unix/geteuid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c
index d0ed4bff..a3039d56 100644
--- a/otherlibs/unix/getgid.c
+++ b/otherlibs/unix/getgid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c
index eefaa597..7b212bd2 100644
--- a/otherlibs/unix/getgr.c
+++ b/otherlibs/unix/getgr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c
index 4d34d5be..485fabc4 100644
--- a/otherlibs/unix/getgroups.c
+++ b/otherlibs/unix/getgroups.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
index 36fdfd8e..b0b29d9e 100644
--- a/otherlibs/unix/gethost.c
+++ b/otherlibs/unix/gethost.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c
index f84f8f5b..cf334e9b 100644
--- a/otherlibs/unix/gethostname.c
+++ b/otherlibs/unix/gethostname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c
index 132ed443..60197a07 100644
--- a/otherlibs/unix/getlogin.c
+++ b/otherlibs/unix/getlogin.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c
index c8878569..eea15c59 100644
--- a/otherlibs/unix/getnameinfo.c
+++ b/otherlibs/unix/getnameinfo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c
index 20a837ca..3c4da556 100644
--- a/otherlibs/unix/getpeername.c
+++ b/otherlibs/unix/getpeername.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c
index cb522749..5cc4f3a6 100644
--- a/otherlibs/unix/getpid.c
+++ b/otherlibs/unix/getpid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c
index 0d69aafb..2d1cd394 100644
--- a/otherlibs/unix/getppid.c
+++ b/otherlibs/unix/getppid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c
index c9ca1a5c..0213e879 100644
--- a/otherlibs/unix/getproto.c
+++ b/otherlibs/unix/getproto.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c
index eba9d6c3..4317dc20 100644
--- a/otherlibs/unix/getpw.c
+++ b/otherlibs/unix/getpw.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c
index e252aacb..626f63b8 100644
--- a/otherlibs/unix/getserv.c
+++ b/otherlibs/unix/getserv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c
index 6f0b64dc..8ab6debb 100644
--- a/otherlibs/unix/getsockname.c
+++ b/otherlibs/unix/getsockname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c
index e095326e..3e203d54 100644
--- a/otherlibs/unix/gettimeofday.c
+++ b/otherlibs/unix/gettimeofday.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c
index 780a8d8e..db3fab13 100644
--- a/otherlibs/unix/getuid.c
+++ b/otherlibs/unix/getuid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c
index 2ffeb392..b55d70f4 100644
--- a/otherlibs/unix/gmtime.c
+++ b/otherlibs/unix/gmtime.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/initgroups.c b/otherlibs/unix/initgroups.c
index df358dae..d5b3dc56 100644
--- a/otherlibs/unix/initgroups.c
+++ b/otherlibs/unix/initgroups.c
@@ -1,6 +1,8 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
+/*                                                                     */
+/*  Contributed by Stephane Glondu                   */
 /*                                                                     */
 /*  Copyright 2009 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -9,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Contributed by Stephane Glondu  */
-
 /* $Id$ */
 
 #include 
diff --git a/otherlibs/unix/isatty.c b/otherlibs/unix/isatty.c
index f534dd77..c2bdaad1 100644
--- a/otherlibs/unix/isatty.c
+++ b/otherlibs/unix/isatty.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c
index 14bac626..7c32783a 100644
--- a/otherlibs/unix/itimer.c
+++ b/otherlibs/unix/itimer.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
index 8d8a4734..715060ee 100644
--- a/otherlibs/unix/kill.c
+++ b/otherlibs/unix/kill.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c
index 181e9c18..e28f649e 100644
--- a/otherlibs/unix/link.c
+++ b/otherlibs/unix/link.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c
index 2f40cfba..503cf6a6 100644
--- a/otherlibs/unix/listen.c
+++ b/otherlibs/unix/listen.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c
index 6e6ce5c1..70359cf7 100644
--- a/otherlibs/unix/lockf.c
+++ b/otherlibs/unix/lockf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
index d8180eae..65d7d50e 100644
--- a/otherlibs/unix/lseek.c
+++ b/otherlibs/unix/lseek.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c
index 1b8fd624..fd935ae6 100644
--- a/otherlibs/unix/mkdir.c
+++ b/otherlibs/unix/mkdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c
index 3e2cf3dd..30f247d9 100644
--- a/otherlibs/unix/mkfifo.c
+++ b/otherlibs/unix/mkfifo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c
index 77def267..a0902f23 100644
--- a/otherlibs/unix/nice.c
+++ b/otherlibs/unix/nice.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c
index 42121830..214a550d 100644
--- a/otherlibs/unix/open.c
+++ b/otherlibs/unix/open.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -36,7 +36,7 @@
 
 static int open_flag_table[] = {
   O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
-  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC
+  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0
 };
 
 CAMLprim value unix_open(value path, value flags, value perm)
diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
index 0497ef1f..bb482581 100644
--- a/otherlibs/unix/opendir.c
+++ b/otherlibs/unix/opendir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c
index b68705e9..81baeaf4 100644
--- a/otherlibs/unix/pipe.c
+++ b/otherlibs/unix/pipe.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c
index e403d296..1238ee2b 100644
--- a/otherlibs/unix/putenv.c
+++ b/otherlibs/unix/putenv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -28,13 +28,16 @@ CAMLprim value unix_putenv(value name, value val)
 {
   mlsize_t namelen = string_length(name);
   mlsize_t vallen = string_length(val);
-  char * s = (char *) stat_alloc(namelen + 1 + vallen + 1);
+  char * s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1);
 
   memmove (s, String_val(name), namelen);
   s[namelen] = '=';
   memmove (s + namelen + 1, String_val(val), vallen);
   s[namelen + 1 + vallen] = 0;
-  if (putenv(s) == -1) uerror("putenv", name);
+  if (putenv(s) == -1) {
+    caml_stat_free(s);
+    uerror("putenv", name);
+  }
   return Val_unit;
 }
 
diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c
index 03a9e6aa..cd1eab8c 100644
--- a/otherlibs/unix/read.c
+++ b/otherlibs/unix/read.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c
index fb8a67b2..1d508ac6 100644
--- a/otherlibs/unix/readdir.c
+++ b/otherlibs/unix/readdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c
index d2b9c4e1..29d28d3d 100644
--- a/otherlibs/unix/readlink.c
+++ b/otherlibs/unix/readlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c
index 65f33c8b..d121037f 100644
--- a/otherlibs/unix/rename.c
+++ b/otherlibs/unix/rename.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c
index d14c526d..7c7b4a3c 100644
--- a/otherlibs/unix/rewinddir.c
+++ b/otherlibs/unix/rewinddir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c
index 8de22346..88749671 100644
--- a/otherlibs/unix/rmdir.c
+++ b/otherlibs/unix/rmdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c
index 612d5970..04938398 100644
--- a/otherlibs/unix/select.c
+++ b/otherlibs/unix/select.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c
index bb3989af..1f884aa8 100644
--- a/otherlibs/unix/sendrecv.c
+++ b/otherlibs/unix/sendrecv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c
index bd8810f8..a1096f26 100644
--- a/otherlibs/unix/setgid.c
+++ b/otherlibs/unix/setgid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/setgroups.c b/otherlibs/unix/setgroups.c
index dd4592ad..e681c976 100644
--- a/otherlibs/unix/setgroups.c
+++ b/otherlibs/unix/setgroups.c
@@ -1,6 +1,8 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
+/*                                                                     */
+/* Contributed by Stephane Glondu                    */
 /*                                                                     */
 /*  Copyright 2009 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -9,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Contributed by Stephane Glondu  */
-
 /* $Id$ */
 
 #include 
diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c
index bfa9dac0..9cc89e64 100644
--- a/otherlibs/unix/setsid.c
+++ b/otherlibs/unix/setsid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c
index c867f4c6..4af0d781 100644
--- a/otherlibs/unix/setuid.c
+++ b/otherlibs/unix/setuid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c
index d51b1a3d..abd8c073 100644
--- a/otherlibs/unix/shutdown.c
+++ b/otherlibs/unix/shutdown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
index c388b139..fb3acf00 100644
--- a/otherlibs/unix/signals.c
+++ b/otherlibs/unix/signals.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
index ec14e39d..aca1003c 100644
--- a/otherlibs/unix/sleep.c
+++ b/otherlibs/unix/sleep.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c
index 82f6329c..7243b8f1 100644
--- a/otherlibs/unix/socket.c
+++ b/otherlibs/unix/socket.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
index f285d15a..caf83b78 100644
--- a/otherlibs/unix/socketaddr.c
+++ b/otherlibs/unix/socketaddr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h
index 79bc80fa..43d7e91b 100644
--- a/otherlibs/unix/socketaddr.h
+++ b/otherlibs/unix/socketaddr.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c
index df4dcff0..8a52dbb8 100644
--- a/otherlibs/unix/socketpair.c
+++ b/otherlibs/unix/socketpair.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c
index 31c95c1f..6b3bfa4a 100644
--- a/otherlibs/unix/sockopt.c
+++ b/otherlibs/unix/sockopt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
index 9cd00006..17ae53c0 100644
--- a/otherlibs/unix/stat.c
+++ b/otherlibs/unix/stat.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c
index ad9ea191..a2c8cdc7 100644
--- a/otherlibs/unix/strofaddr.c
+++ b/otherlibs/unix/strofaddr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c
index 6085fd51..b66c76bd 100644
--- a/otherlibs/unix/symlink.c
+++ b/otherlibs/unix/symlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c
index ce49d77e..99cca2b6 100644
--- a/otherlibs/unix/termios.c
+++ b/otherlibs/unix/termios.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c
index 2fdf4978..63eac84e 100644
--- a/otherlibs/unix/time.c
+++ b/otherlibs/unix/time.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c
index aa32f10d..94abde8a 100644
--- a/otherlibs/unix/times.c
+++ b/otherlibs/unix/times.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
index c23eb47b..dfc350a3 100644
--- a/otherlibs/unix/truncate.c
+++ b/otherlibs/unix/truncate.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c
index 6f5d14fd..cf5eaa7c 100644
--- a/otherlibs/unix/umask.c
+++ b/otherlibs/unix/umask.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index 8de827b0..0adc41e2 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -151,6 +151,7 @@ type open_flag =
   | O_DSYNC
   | O_SYNC
   | O_RSYNC
+  | O_SHARE_DELETE
 
 type file_perm = int
 
@@ -838,27 +839,47 @@ let open_proc cmd proc input output toclose =
 let open_process_in cmd =
   let (in_read, in_write) = pipe() in
   let inchan = in_channel_of_descr in_read in
-  open_proc cmd (Process_in inchan) stdin in_write [in_read];
+  begin
+    try
+      open_proc cmd (Process_in inchan) stdin in_write [in_read];
+    with e ->
+      close_in inchan;
+      close in_write;
+      raise e
+  end;
   close in_write;
   inchan
 
 let open_process_out cmd =
   let (out_read, out_write) = pipe() in
   let outchan = out_channel_of_descr out_write in
-  open_proc cmd (Process_out outchan) out_read stdout [out_write];
+  begin
+    try
+      open_proc cmd (Process_out outchan) out_read stdout [out_write];
+    with e ->
+      close_out outchan;
+      close out_read;
+      raise e
+  end;
   close out_read;
   outchan
 
 let open_process cmd =
   let (in_read, in_write) = pipe() in
-  let (out_read, out_write) = pipe() in
-  let inchan = in_channel_of_descr in_read in
-  let outchan = out_channel_of_descr out_write in
-  open_proc cmd (Process(inchan, outchan)) out_read in_write
+  let fds_to_close = ref [in_read;in_write] in
+  try
+    let (out_read, out_write) = pipe() in
+    fds_to_close := [in_read;in_write;out_read;out_write];
+    let inchan = in_channel_of_descr in_read in
+    let outchan = out_channel_of_descr out_write in
+    open_proc cmd (Process(inchan, outchan)) out_read in_write
                                            [in_read; out_write];
-  close out_read;
-  close in_write;
-  (inchan, outchan)
+    close out_read;
+    close in_write;
+    (inchan, outchan)
+  with e ->
+    List.iter close !fds_to_close;
+    raise e
 
 let open_proc_full cmd env proc input output error toclose =
   let cloexec = List.for_all try_set_close_on_exec toclose in
@@ -874,17 +895,24 @@ let open_proc_full cmd env proc input output error toclose =
 
 let open_process_full cmd env =
   let (in_read, in_write) = pipe() in
-  let (out_read, out_write) = pipe() in
-  let (err_read, err_write) = pipe() in
-  let inchan = in_channel_of_descr in_read in
-  let outchan = out_channel_of_descr out_write in
-  let errchan = in_channel_of_descr err_read in
-  open_proc_full cmd env (Process_full(inchan, outchan, errchan))
-                 out_read in_write err_write [in_read; out_write; err_read];
-  close out_read;
-  close in_write;
-  close err_write;
-  (inchan, outchan, errchan)
+  let fds_to_close = ref [in_read;in_write] in
+  try
+    let (out_read, out_write) = pipe() in
+    fds_to_close := out_read::out_write:: !fds_to_close;
+    let (err_read, err_write) = pipe() in
+    fds_to_close := err_read::err_write:: !fds_to_close;
+    let inchan = in_channel_of_descr in_read in
+    let outchan = out_channel_of_descr out_write in
+    let errchan = in_channel_of_descr err_read in
+    open_proc_full cmd env (Process_full(inchan, outchan, errchan))
+      out_read in_write err_write [in_read; out_write; err_read];
+    close out_read;
+    close in_write;
+    close err_write;
+    (inchan, outchan, errchan)
+  with e ->
+    List.iter close !fds_to_close;
+    raise e
 
 let find_proc_id fun_name proc =
   try
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index 614c206f..0c278099 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -122,7 +122,7 @@ val environment : unit -> string array
 val getenv : string -> string
 (** Return the value associated to a variable in the process
    environment. Raise [Not_found] if the variable is unbound.
-   (This function is identical to [Sys.getenv].) *)
+   (This function is identical to {!Sys.getenv}.) *)
 
 val putenv : string -> string -> unit
 (** [Unix.putenv name value] sets the value associated to a
@@ -235,9 +235,14 @@ type open_flag =
   | O_TRUNC                     (** Truncate to 0 length if existing *)
   | O_EXCL                      (** Fail if existing *)
   | O_NOCTTY                    (** Don't make this dev a controlling tty *)
-  | O_DSYNC                     (** Writes complete as `Synchronised I/O data integrity completion' *)
-  | O_SYNC                      (** Writes complete as `Synchronised I/O file integrity completion' *)
-  | O_RSYNC                     (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
+  | O_DSYNC                     (** Writes complete as `Synchronised I/O data
+                                   integrity completion' *)
+  | O_SYNC                      (** Writes complete as `Synchronised I/O file
+                                   integrity completion' *)
+  | O_RSYNC                     (** Reads complete as writes (depending on
+                                   O_SYNC/O_DSYNC) *)
+  | O_SHARE_DELETE              (** Windows only: allow the file to be deleted
+                                   while still open *)
 (** The flags to {!Unix.openfile}. *)
 
 
@@ -765,9 +770,11 @@ val utimes : string -> float -> float -> unit
 
 type interval_timer =
     ITIMER_REAL
-      (** decrements in real time, and sends the signal [SIGALRM] when expired.*)
+      (** decrements in real time, and sends the signal [SIGALRM] when
+         expired.*)
   | ITIMER_VIRTUAL
-      (**  decrements in process virtual time, and sends [SIGVTALRM] when expired. *)
+      (** decrements in process virtual time, and sends [SIGVTALRM]
+          when expired. *)
   | ITIMER_PROF
       (** (for profiling) decrements both when the process
          is running and when the system is running on behalf of the
@@ -1022,8 +1029,9 @@ type socket_int_option =
   | SO_RCVBUF      (** Size of received buffer *)
   | SO_ERROR       (** Deprecated.  Use {!Unix.getsockopt_error} instead. *)
   | SO_TYPE        (** Report the socket type *)
-  | SO_RCVLOWAT    (** Minimum number of bytes to process for input operations *)
-  | SO_SNDLOWAT    (** Minimum number of bytes to process for output operations *)
+  | SO_RCVLOWAT    (** Minimum number of bytes to process for input operations*)
+  | SO_SNDLOWAT    (** Minimum number of bytes to process for output
+                       operations *)
 (** The socket options that can be consulted with {!Unix.getsockopt_int}
    and modified with {!Unix.setsockopt_int}.  These options have an
    integer value. *)
@@ -1058,17 +1066,21 @@ val setsockopt_int : file_descr -> socket_int_option -> int -> unit
 (** Same as {!Unix.setsockopt} for an integer-valued socket option. *)
 
 val getsockopt_optint : file_descr -> socket_optint_option -> int option
-(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *)
+(** Same as {!Unix.getsockopt} for a socket option whose value is an
+   [int option]. *)
 
 val setsockopt_optint :
       file_descr -> socket_optint_option -> int option -> unit
-(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *)
+(** Same as {!Unix.setsockopt} for a socket option whose value is an
+   [int option]. *)
 
 val getsockopt_float : file_descr -> socket_float_option -> float
-(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *)
+(** Same as {!Unix.getsockopt} for a socket option whose value is a
+   floating-point number. *)
 
 val setsockopt_float : file_descr -> socket_float_option -> float -> unit
-(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *)
+(** Same as {!Unix.setsockopt} for a socket option whose value is a
+   floating-point number. *)
 
 val getsockopt_error : file_descr -> error option
 (** Return the error condition associated with the given socket,
diff --git a/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml
index 683f15ec..424fcc6e 100644
--- a/otherlibs/unix/unixLabels.ml
+++ b/otherlibs/unix/unixLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index 7126d23e..98a58f1b 100644
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -240,6 +240,7 @@ type open_flag = Unix.open_flag =
   | O_DSYNC                     (** Writes complete as `Synchronised I/O data integrity completion' *)
   | O_SYNC                      (** Writes complete as `Synchronised I/O file integrity completion' *)
   | O_RSYNC                     (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
+  | O_SHARE_DELETE              (** Windows only: allow the file to be deleted while still open *)
 (** The flags to {!UnixLabels.openfile}. *)
 
 
diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c
index c6eaf706..4c91adb1 100644
--- a/otherlibs/unix/unixsupport.c
+++ b/otherlibs/unix/unixsupport.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -165,7 +165,11 @@
 #define ESOCKTNOSUPPORT (-1)
 #endif
 #ifndef EOPNOTSUPP
-#define EOPNOTSUPP (-1)
+#  ifdef ENOTSUP
+#    define EOPNOTSUPP ENOTSUP
+#  else
+#    define EOPNOTSUPP (-1)
+#  endif
 #endif
 #ifndef EPFNOSUPPORT
 #define EPFNOSUPPORT (-1)
@@ -252,6 +256,11 @@ value unix_error_of_code (int errcode)
   int errconstr;
   value err;
 
+#if defined(ENOTSUP) && (EOPNOTSUPP != ENOTSUP)
+  if (errcode == ENOTSUP)
+    errcode = EOPNOTSUPP;
+#endif
+
   errconstr =
       cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
   if (errconstr == Val_int(-1)) {
diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
index 84179f43..a90bb2dc 100644
--- a/otherlibs/unix/unixsupport.h
+++ b/otherlibs/unix/unixsupport.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c
index 1d956758..3fb5151b 100644
--- a/otherlibs/unix/unlink.c
+++ b/otherlibs/unix/unlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c
index da291357..a6a2f5eb 100644
--- a/otherlibs/unix/utimes.c
+++ b/otherlibs/unix/utimes.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
index 486d06af..fc12e5ad 100644
--- a/otherlibs/unix/wait.c
+++ b/otherlibs/unix/wait.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
index 9ddf74e3..ca42d1e7 100644
--- a/otherlibs/unix/write.c
+++ b/otherlibs/unix/write.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32graph/.cvsignore b/otherlibs/win32graph/.cvsignore
deleted file mode 100644
index 090a9a25..00000000
--- a/otherlibs/win32graph/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-graphics.ml
-graphics.mli
diff --git a/otherlibs/win32graph/.ignore b/otherlibs/win32graph/.ignore
new file mode 100644
index 00000000..090a9a25
--- /dev/null
+++ b/otherlibs/win32graph/.ignore
@@ -0,0 +1,2 @@
+graphics.ml
+graphics.mli
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 12e3d239..453d9f3c 100644
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c
index cbf4725a..8acba6f1 100644
--- a/otherlibs/win32graph/dib.c
+++ b/otherlibs/win32graph/dib.c
@@ -1,8 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Developed by Jacob Navia                                           */
+/*                                                                     */
 /*  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    */
diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
index 62710ec0..f089a01a 100644
--- a/otherlibs/win32graph/draw.c
+++ b/otherlibs/win32graph/draw.c
@@ -1,8 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */
+/*                                                                     */
 /*  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    */
@@ -452,7 +453,8 @@ static struct custom_operations image_ops = {
         custom_compare_default,
         custom_hash_default,
         custom_serialize_default,
-        custom_deserialize_default
+        custom_deserialize_default,
+        custom_compare_ext_default
 };
 
 CAMLprim value caml_gr_create_image(value vw, value vh)
diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
index 9e0791c3..29def467 100755
--- a/otherlibs/win32graph/events.c
+++ b/otherlibs/win32graph/events.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h
index 6c32f15d..bae4b116 100644
--- a/otherlibs/win32graph/libgraph.h
+++ b/otherlibs/win32graph/libgraph.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Jacob Navia, after Xavier Leroy                          */
 /*                                                                     */
@@ -43,8 +43,8 @@ extern int bits_per_pixel;
 #define DEFAULT_SCREEN_WIDTH 1024
 #define DEFAULT_SCREEN_HEIGHT 768
 #define BORDER_WIDTH 2
-#define WINDOW_NAME "Caml graphics"
-#define ICON_NAME "Caml graphics"
+#define WINDOW_NAME "OCaml graphics"
+#define ICON_NAME "OCaml graphics"
 #define SIZE_QUEUE 256
 
 void gr_fail(char *fmt, char *arg);
diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index 2797bc66..a6bc59d4 100644
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -1,8 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */
+/*                                                                     */
 /*  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    */
@@ -237,7 +238,7 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
   caml_gr_init_event_queue();
 
   /* The global data structures are now correctly initialized.
-     Restart the Caml main thread. */
+     Restart the OCaml main thread. */
   open_graph_errmsg = NULL;
   SetEvent(open_graph_event);
 
diff --git a/otherlibs/win32unix/.cvsignore b/otherlibs/win32unix/.cvsignore
deleted file mode 100644
index e85bbd9a..00000000
--- a/otherlibs/win32unix/.cvsignore
+++ /dev/null
@@ -1,27 +0,0 @@
-unixLabels.ml*
-unix.mli
-unix.lib
-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
-getserv.c
-gmtime.c
-putenv.c
-rmdir.c
-socketaddr.c
-strofaddr.c
-time.c
-unlink.c
-utimes.c
diff --git a/otherlibs/win32unix/.ignore b/otherlibs/win32unix/.ignore
new file mode 100644
index 00000000..e85bbd9a
--- /dev/null
+++ b/otherlibs/win32unix/.ignore
@@ -0,0 +1,27 @@
+unixLabels.ml*
+unix.mli
+unix.lib
+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
+getserv.c
+gmtime.c
+putenv.c
+rmdir.c
+socketaddr.c
+strofaddr.c
+time.c
+unlink.c
+utimes.c
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index 0d98b316..84f1574a 100644
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -21,7 +21,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
   mkdir.c open.c pipe.c read.c rename.c \
   select.c sendrecv.c \
   shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
-  system.c unixsupport.c windir.c winwait.c write.c \
+  system.c times.c unixsupport.c windir.c winwait.c write.c \
   winlist.c winworker.c windbug.c
 
 # Files from the ../unix directory
diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c
index 1d54b89b..68c7bac7 100644
--- a/otherlibs/win32unix/accept.c
+++ b/otherlibs/win32unix/accept.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,30 +26,15 @@ CAMLprim value unix_accept(sock)
   SOCKET sconn = Socket_val(sock);
   SOCKET snew;
   value fd = Val_unit, adr = Val_unit, res;
-  int oldvalue, oldvaluelen, newvalue, retcode;
   union sock_addr_union addr;
   socklen_param_type addr_len;
   DWORD err = 0;
 
-  oldvaluelen = sizeof(oldvalue);
-  retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-                       (char *) &oldvalue, &oldvaluelen);
-  if (retcode == 0) {
-    /* Set sockets to synchronous mode */
-    newvalue = SO_SYNCHRONOUS_NONALERT;
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &newvalue, sizeof(newvalue));
-  }
   addr_len = sizeof(sock_addr);
   enter_blocking_section();
   snew = accept(sconn, &addr.s_gen, &addr_len);
   if (snew == INVALID_SOCKET) err = WSAGetLastError ();
   leave_blocking_section();
-  if (retcode == 0) {
-    /* Restore initial mode */
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &oldvalue, oldvaluelen);
-  }
   if (snew == INVALID_SOCKET) {
     win32_maperr(err);
     uerror("accept", Nothing);
diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c
index fca96948..84d07570 100644
--- a/otherlibs/win32unix/bind.c
+++ b/otherlibs/win32unix/bind.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index 56a19c7d..ea391272 100644
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -20,15 +20,15 @@
 #include "unixsupport.h"
 #include 
 
-extern long _get_osfhandle(int);
-extern int _open_osfhandle(long, int);
+extern intptr_t _get_osfhandle(int);
+extern int _open_osfhandle(intptr_t, int);
 
 int win_CRT_fd_of_filedescr(value handle)
 {
   if (CRT_fd_val(handle) != NO_CRT_FD) {
     return CRT_fd_val(handle);
   } else {
-    int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY);
+    int fd = _open_osfhandle((intptr_t) Handle_val(handle), O_BINARY);
     if (fd == -1) uerror("channel_of_descr", Nothing);
     CRT_fd_val(handle) = fd;
     return fd;
diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c
index 21254ef1..f7463690 100644
--- a/otherlibs/win32unix/close.c
+++ b/otherlibs/win32unix/close.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c
index 5b2c4ece..03ff2b89 100644
--- a/otherlibs/win32unix/close_on.c
+++ b/otherlibs/win32unix/close_on.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -19,17 +19,14 @@
 
 int win_set_inherit(value fd, BOOL inherit)
 {
-  HANDLE oldh, newh;
-
-  oldh = Handle_val(fd);
-  if (! DuplicateHandle(GetCurrentProcess(), oldh,
-                        GetCurrentProcess(), &newh,
-                        0L, inherit, DUPLICATE_SAME_ACCESS)) {
+  /* According to the MSDN, SetHandleInformation may not work
+     for console handles on WinNT4 and earlier versions. */
+  if (! SetHandleInformation(Handle_val(fd),
+			     HANDLE_FLAG_INHERIT,
+			     inherit ? HANDLE_FLAG_INHERIT : 0)) {
     win32_maperr(GetLastError());
     return -1;
   }
-  Handle_val(fd) = newh;
-  CloseHandle(oldh);
   return 0;
 }
 
diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c
index 198d02e2..bd342a2e 100644
--- a/otherlibs/win32unix/connect.c
+++ b/otherlibs/win32unix/connect.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c
index 042eaef9..714513ca 100644
--- a/otherlibs/win32unix/createprocess.c
+++ b/otherlibs/win32unix/createprocess.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c
index 2668e75b..a86211bb 100644
--- a/otherlibs/win32unix/dup.c
+++ b/otherlibs/win32unix/dup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c
index 3f6d37e7..f224fc54 100644
--- a/otherlibs/win32unix/dup2.c
+++ b/otherlibs/win32unix/dup2.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
index 9ce9dddb..1f07e514 100644
--- a/otherlibs/win32unix/errmsg.c
+++ b/otherlibs/win32unix/errmsg.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c
index 9aeb4c21..8517f546 100644
--- a/otherlibs/win32unix/getpeername.c
+++ b/otherlibs/win32unix/getpeername.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c
index 0892f8f9..677acdc5 100644
--- a/otherlibs/win32unix/getpid.c
+++ b/otherlibs/win32unix/getpid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c
index 88487a43..3af6c341 100644
--- a/otherlibs/win32unix/getsockname.c
+++ b/otherlibs/win32unix/getsockname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
index f1313f06..b68eeb1a 100644
--- a/otherlibs/win32unix/gettimeofday.c
+++ b/otherlibs/win32unix/gettimeofday.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c
index 89214342..05320491 100644
--- a/otherlibs/win32unix/link.c
+++ b/otherlibs/win32unix/link.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*                 File contributed by Lionel Fourquaux                */
 /*                                                                     */
diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c
index 20789e1a..402247fd 100644
--- a/otherlibs/win32unix/listen.c
+++ b/otherlibs/win32unix/listen.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c
index 524f9516..1a47824d 100644
--- a/otherlibs/win32unix/lockf.c
+++ b/otherlibs/win32unix/lockf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Tracy Camp, PolyServe Inc.,    */
 /*  Further improvements by Reed Wilson                                */
diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c
index 9619fcc9..86ea537d 100644
--- a/otherlibs/win32unix/lseek.c
+++ b/otherlibs/win32unix/lseek.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c
index aae54783..d47d7a28 100644
--- a/otherlibs/win32unix/mkdir.c
+++ b/otherlibs/win32unix/mkdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c
index 1bf80bfc..1f2550b0 100755
--- a/otherlibs/win32unix/nonblock.c
+++ b/otherlibs/win32unix/nonblock.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,7 +26,7 @@ CAMLprim value unix_set_nonblock(socket)
     win32_maperr(WSAGetLastError());
     uerror("unix_set_nonblock", Nothing);
   }
-  Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING;
+  Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING;
   return Val_unit;
 }
 
@@ -39,6 +39,6 @@ CAMLprim value unix_clear_nonblock(socket)
     win32_maperr(WSAGetLastError());
     uerror("unix_clear_nonblock", Nothing);
   }
-  Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING;
+  Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING;
   return Val_unit;
 }
diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c
index f2f334bb..74fe8fc9 100644
--- a/otherlibs/win32unix/open.c
+++ b/otherlibs/win32unix/open.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -18,22 +18,27 @@
 #include "unixsupport.h"
 #include 
 
-static int open_access_flags[12] = {
+static int open_access_flags[13] = {
   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
 };
 
-static int open_create_flags[12] = {
-  0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 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[13] = {
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE
 };
 
 CAMLprim value unix_open(value path, value flags, value perm)
 {
-  int fileaccess, createflags, fileattrib, filecreate;
+  int fileaccess, createflags, fileattrib, filecreate, sharemode;
   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);
 
   createflags = convert_flag_list(flags, open_create_flags);
   if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
@@ -57,7 +62,7 @@ CAMLprim value unix_open(value path, value flags, value perm)
   attr.bInheritHandle = TRUE;
 
   h = CreateFile(String_val(path), fileaccess,
-                 FILE_SHARE_READ | FILE_SHARE_WRITE, &attr,
+                 sharemode, &attr,
                  filecreate, fileattrib, NULL);
   if (h == INVALID_HANDLE_VALUE) {
     win32_maperr(GetLastError());
diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c
index afacd3e1..ca0df369 100644
--- a/otherlibs/win32unix/pipe.c
+++ b/otherlibs/win32unix/pipe.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c
index 67882eb7..c885857b 100644
--- a/otherlibs/win32unix/read.c
+++ b/otherlibs/win32unix/read.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
index 9ab43fca..6b750eba 100644
--- a/otherlibs/win32unix/rename.c
+++ b/otherlibs/win32unix/rename.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Tracy Camp, PolyServe Inc.,    */
 /*                                                                     */
diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
index b82c423c..7069d140 100644
--- a/otherlibs/win32unix/select.c
+++ b/otherlibs/win32unix/select.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
@@ -114,9 +114,9 @@ typedef enum _SELECTHANDLETYPE {
 
 typedef enum _SELECTMODE {
   SELECT_MODE_NONE = 0,
-  SELECT_MODE_READ,
-  SELECT_MODE_WRITE, 
-  SELECT_MODE_EXCEPT,
+  SELECT_MODE_READ = 1,
+  SELECT_MODE_WRITE = 2, 
+  SELECT_MODE_EXCEPT = 4,
 } SELECTMODE;
 
 typedef enum _SELECTSTATE {
@@ -157,7 +157,9 @@ typedef SELECTQUERY *LPSELECTQUERY;
 typedef struct _SELECTDATA {
   LIST             lst;
   SELECTTYPE       EType;
-  SELECTRESULT     aResults[MAXIMUM_SELECT_OBJECTS];
+  /* Sockets may generate a result for all three lists from one single query object
+   */
+  SELECTRESULT     aResults[MAXIMUM_SELECT_OBJECTS * 3];
   DWORD            nResultsCount;
   /* Data following are dedicated to APC like call, they
      will be initialized if required.
@@ -240,7 +242,7 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int l
   DWORD i;
 
   res = 0;
-  if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS)
+  if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS * 3)
   {
     i = lpSelectData->nResultsCount;
     lpSelectData->aResults[i].EMode  = EMode;
@@ -490,31 +492,38 @@ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData,
 void socket_poll (HANDLE hStop, void *_data)
 {
   LPSELECTDATA   lpSelectData;
-  LPSELECTQUERY  iterQuery;
-  HANDLE         aEvents[MAXIMUM_SELECT_OBJECTS];
-  DWORD          nEvents;
-  long           maskEvents;
-  DWORD          i;
-  u_long         iMode;
+  LPSELECTQUERY    iterQuery;
+  HANDLE           aEvents[MAXIMUM_SELECT_OBJECTS];
+  DWORD            nEvents;
+  long             maskEvents;
+  DWORD            i;
+  u_long           iMode;
+  SELECTMODE       mode;
+  WSANETWORKEVENTS events;
 
   lpSelectData = (LPSELECTDATA)_data;
 
+  DEBUG_PRINT("Worker has %d queries to service", lpSelectData->nQueriesCount);
   for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++)
   {
     iterQuery = &(lpSelectData->aQueries[nEvents]);
     aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL);
     maskEvents = 0;
-    switch (iterQuery->EMode)
+    mode = iterQuery->EMode;
+    if ((mode & SELECT_MODE_READ) != 0)
     {
-      case SELECT_MODE_READ:
-        maskEvents = FD_READ | FD_ACCEPT | FD_CLOSE;
-        break;
-      case SELECT_MODE_WRITE:
-        maskEvents = FD_WRITE | FD_CONNECT | FD_CLOSE;
-        break;
-      case SELECT_MODE_EXCEPT:
-        maskEvents = FD_OOB;
-        break;
+      DEBUG_PRINT("Polling read for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_READ | FD_ACCEPT | FD_CLOSE;
+    }
+    if ((mode & SELECT_MODE_WRITE) != 0)
+    {
+      DEBUG_PRINT("Polling write for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_WRITE | FD_CONNECT | FD_CLOSE;
+    }
+    if ((mode & SELECT_MODE_EXCEPT) != 0)
+    {
+      DEBUG_PRINT("Polling exceptions for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_OOB;
     }
 
     check_error(lpSelectData,
@@ -548,7 +557,23 @@ void socket_poll (HANDLE hStop, void *_data)
         DEBUG_PRINT("Socket %d has pending events", (i - 1));
         if (iterQuery != NULL)
         {
-          select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx);
+          /* Find out what kind of events were raised
+           */
+          if (WSAEnumNetworkEvents((SOCKET)(iterQuery->hFileDescr), aEvents[i], &events) == 0)
+          {
+            if ((iterQuery->EMode & SELECT_MODE_READ) != 0 && (events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_READ, iterQuery->lpOrigIdx);
+            }
+            if ((iterQuery->EMode & SELECT_MODE_WRITE) != 0 && (events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE)) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_WRITE, iterQuery->lpOrigIdx);
+            }
+            if ((iterQuery->EMode & SELECT_MODE_EXCEPT) != 0 && (events.lNetworkEvents & FD_OOB) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_EXCEPT, iterQuery->lpOrigIdx);
+            }
+          }
         }
       }
       /* WSAEventSelect() automatically sets socket to nonblocking mode.
@@ -556,7 +581,7 @@ void socket_poll (HANDLE hStop, void *_data)
       if (iterQuery->uFlagsFd & FLAGS_FD_IS_BLOCKING)
       {
         DEBUG_PRINT("Restore a blocking socket");
-        iMode = 1;
+        iMode = 0;
         check_error(lpSelectData,
           WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0 ||
           ioctlsocket((SOCKET)(iterQuery->hFileDescr), FIONBIO, &iMode) != 0);
@@ -581,23 +606,88 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData,
                               unsigned int uFlagsFd)
 {
   LPSELECTDATA res;
-  LPSELECTDATA hd;
+  LPSELECTDATA candidate;
+  DWORD i;
+  LPSELECTQUERY aQueries;
   
-  hd = lpSelectData;
+  res = lpSelectData;
+  candidate = NULL;
+  aQueries = NULL;
+
   /* Polling socket can be done mulitple handle at the same time. You just
      need one worker to use it. Try to find if there is already a worker
      handling this kind of request.
+     Only one event can be associated with a given socket which means that if a socket
+     is in more than one of the fd_sets then we have to find that particular query and update
+     EMode with the additional flag.
      */
   DEBUG_PRINT("Scanning list of worker to find one that already handle socket");
-  res = select_data_job_search(&hd, SELECT_TYPE_SOCKET);
-  
-  /* Add a new socket to poll */
-  res->funcWorker = socket_poll;
-  DEBUG_PRINT("Add socket %x to worker", hFileDescr);
-  select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
-  DEBUG_PRINT("Socket %x added", hFileDescr);
+  /* Search for job */
+  DEBUG_PRINT("Searching for an available job for type %d for descriptor %d", SELECT_TYPE_SOCKET, hFileDescr);
+  while (res != NULL)
+  {
+    if (res->EType == SELECT_TYPE_SOCKET)
+    {
+      i = res->nQueriesCount - 1;
+      aQueries = res->aQueries;
+      while (i >= 0 && aQueries[i].hFileDescr != hFileDescr)
+      {
+        i--;
+      }
+      /* If we didn't find the socket but this worker has available slots, store it
+       */
+      if (i < 0)
+      {
+        if ( res->nQueriesCount < MAXIMUM_SELECT_OBJECTS)
+        {
+          candidate = res;
+        }
+        res = LIST_NEXT(LPSELECTDATA, res);
+      }
+      else
+      {
+        /* Previous socket query located -- we're finished
+         */
+        aQueries = &aQueries[i];
+        break;
+      }
+    }
+    else
+    {
+      res = LIST_NEXT(LPSELECTDATA, res);
+    }
+  }
 
-  return hd;
+  if (res == NULL)
+  {
+    res = candidate;
+
+    /* No matching job found, create one */
+    if (res == NULL)
+    {
+      DEBUG_PRINT("No job for type %d found, create one", SELECT_TYPE_SOCKET);
+      res = select_data_new(lpSelectData, SELECT_TYPE_SOCKET);
+      res->funcWorker = socket_poll;
+      res->nQueriesCount = 1;
+      aQueries = &res->aQueries[0];
+    }
+    else
+    {
+      aQueries = &(res->aQueries[res->nQueriesCount++]);
+    }
+    aQueries->EMode = EMode;
+    aQueries->hFileDescr = hFileDescr;
+    aQueries->lpOrigIdx = lpOrigIdx;
+    aQueries->uFlagsFd = uFlagsFd;
+    DEBUG_PRINT("Socket %x added", hFileDescr);
+  }
+  else
+  {
+    aQueries->EMode |= EMode;
+    DEBUG_PRINT("Socket %x updated to %d", hFileDescr, aQueries->EMode);
+  }
+
+  return res;
 }
 
 /***********************/
@@ -817,6 +907,42 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd
 
 #define MAX(a, b) ((a) > (b) ? (a) : (b))
 
+/* Convert fdlist to an fd_set if all the handles in fdlist are sockets and return 0.
+ * Returns 1 if a non-socket value is encountered.
+ */
+static int fdlist_to_fdset(value fdlist, fd_set *fdset)
+{
+  value l, c;
+  FD_ZERO(fdset);
+  for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    c = Field(l, 0);
+    if (Descr_kind_val(c) == KIND_SOCKET) {
+      FD_SET(Socket_val(c), fdset);
+    } else {
+      DEBUG_PRINT("Non socket value encountered");
+      return 0;
+    }
+  }
+  return 1;
+}
+
+static value fdset_to_fdlist(value fdlist, fd_set *fdset)
+{
+  value res = Val_int(0);
+  Begin_roots2(fdlist, res)
+    for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
+      value s = Field(fdlist, 0);
+      if (FD_ISSET(Socket_val(s), fdset)) {
+        value newres = alloc_small(2, 0);
+        Field(newres, 0) = s;
+        Field(newres, 1) = res;
+        res = newres;
+      }
+    }
+  End_roots();
+  return res;
+}
+
 CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout)
 {  
   /* Event associated to handle */
@@ -860,246 +986,287 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value
   CAMLlocal5 (read_list, write_list, except_list, res, l);
   CAMLlocal1 (fd);
 
+  fd_set read, write, except;
+  double tm;
+  struct timeval tv;
+  struct timeval * tvp;
+  
   DEBUG_PRINT("in select");
 
-  nEventsCount   = 0;
-  nEventsMax     = 0;
-  lpEventsDone   = NULL;
-  lpSelectData   = NULL;
-  iterSelectData = NULL;
-  iterResult     = NULL;
-  err            = 0;
-  hasStaticData  = 0;
-  waitRet        = 0;
-  readfds_len    = caml_list_length(readfds);
-  writefds_len   = caml_list_length(writefds);
-  exceptfds_len  = caml_list_length(exceptfds);
-  hdsMax         = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
-
-  hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
-
-  if (Double_val(timeout) >= 0.0)
-  {
-    milliseconds = 1000 * Double_val(timeout);
-    DEBUG_PRINT("Will wait %d ms", milliseconds);
-  }
-  else
-  {
-    milliseconds = INFINITE;
-  }
-
-
-  /* Create list of select data, based on the different list of fd to watch */
-  DEBUG_PRINT("Dispatch read fd");
-  handle_set_init(&hds, hdsData, hdsMax);
-  i=0;
-  for (l = readfds; l != Val_int(0); l = Field(l, 1))
-  {
-    fd = Field(l, 0);
-    if (!handle_set_mem(&hds, Handle_val(fd)))
-    {
-      handle_set_add(&hds, Handle_val(fd));
-      lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++);
-    }
-    else
-    {
-      DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd));
-    }
-  }
-  handle_set_reset(&hds);
-
-  DEBUG_PRINT("Dispatch write fd");
-  handle_set_init(&hds, hdsData, hdsMax);
-  i=0;
-  for (l = writefds; l != Val_int(0); l = Field(l, 1))
-  {
-    fd = Field(l, 0);
-    if (!handle_set_mem(&hds, Handle_val(fd)))
-    {
-      handle_set_add(&hds, Handle_val(fd));
-      lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++);
-    }
-    else
-    {
-      DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd));
+  err = 0;
+  tm = Double_val(timeout);
+  if (readfds == Val_int(0) && writefds == Val_int(0) && exceptfds == Val_int(0)) {
+    DEBUG_PRINT("nothing to do");
+    if ( tm > 0.0 ) {
+      enter_blocking_section();
+      Sleep( (int)(tm * 1000));
+      leave_blocking_section();
     }
-  }
-  handle_set_reset(&hds);
-
-  DEBUG_PRINT("Dispatch exceptional fd");
-  handle_set_init(&hds, hdsData, hdsMax);
-  i=0;
-  for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
-  {
-    fd = Field(l, 0);
-    if (!handle_set_mem(&hds, Handle_val(fd)))
-    {
-      handle_set_add(&hds, Handle_val(fd));
-      lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++);
-    }
-    else
-    {
-      DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd));
-    }
-  }
-  handle_set_reset(&hds);
-
-  /* Building the list of handle to wait for */
-  DEBUG_PRINT("Building events done array");
-  nEventsMax   = list_length((LPLIST)lpSelectData);
-  nEventsCount = 0;
-  lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
-
-  iterSelectData = lpSelectData;
-  while (iterSelectData != NULL)
-  {
-    /* Check if it is static data. If this is the case, launch everything
-     * but don't wait for events. It helps to test if there are events on
-     * any other fd (which are not static), knowing that there is at least
-     * one result (the static data).
-     */
-    if (iterSelectData->EType == SELECT_TYPE_STATIC)
-    {
-      hasStaticData = TRUE;
-    };
-
-    /* Execute APC */
-    if (iterSelectData->funcWorker != NULL)
-    {
-      iterSelectData->lpWorker = 
-        worker_job_submit(
-            iterSelectData->funcWorker, 
-            (void *)iterSelectData);
-      DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); 
-      lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker);
-      nEventsCount++;
-    };
-    iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
-  };
-
-  DEBUG_PRINT("Need to watch %d workers", nEventsCount);
-
-  /* Processing select itself */
-  enter_blocking_section();
-  /* There are worker started, waiting to be monitored */
-  if (nEventsCount > 0)
-  {
-    /* Waiting for event */
-    if (err == 0 && !hasStaticData)
-    {
-      DEBUG_PRINT("Waiting for one select worker to be done");
-      switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds))
-      {
-        case WAIT_FAILED:
-          err = GetLastError();
-          break;
-
-        case WAIT_TIMEOUT:
-          DEBUG_PRINT("Select timeout");
-          break;
-
-        default:
-          DEBUG_PRINT("One worker is done");
-          break;
-      };
-    }
-
-    /* Ordering stop to every worker */
-    DEBUG_PRINT("Sending stop signal to every select workers");
-    iterSelectData = lpSelectData;
-    while (iterSelectData != NULL)
-    {
-      if (iterSelectData->lpWorker != NULL)
-      {
-        worker_job_stop(iterSelectData->lpWorker);
-      };
-      iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
-    };
+    read_list = write_list = except_list = Val_int(0);
+  } else {      
+    if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) {
+      DEBUG_PRINT("only sockets to select on, using classic select");
+      if (tm < 0.0) {
+        tvp = (struct timeval *) NULL;
+      } else {
+        tv.tv_sec = (int) tm;
+        tv.tv_usec = (int) (1e6 * (tm - (int) tm));
+        tvp = &tv;
+      }
+      enter_blocking_section();
+      if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) {
+        err = WSAGetLastError();
+        DEBUG_PRINT("Error %ld occurred", err);
+      }
+      leave_blocking_section();
+      if (err) {
+        DEBUG_PRINT("Error %ld occurred", err);
+        win32_maperr(err);
+        uerror("select", Nothing);
+      }
+      read_list = fdset_to_fdlist(readfds, &read);
+      write_list = fdset_to_fdlist(writefds, &write);
+      except_list = fdset_to_fdlist(exceptfds, &except);
+    } else {
+      nEventsCount   = 0;
+      nEventsMax     = 0;
+      lpEventsDone   = NULL;
+      lpSelectData   = NULL;
+      iterSelectData = NULL;
+      iterResult     = NULL;
+      hasStaticData  = 0;
+      waitRet        = 0;
+      readfds_len    = caml_list_length(readfds);
+      writefds_len   = caml_list_length(writefds);
+      exceptfds_len  = caml_list_length(exceptfds);
+      hdsMax         = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
       
-    DEBUG_PRINT("Waiting for every select worker to be done");
-    switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE))
-    {
-      case WAIT_FAILED:
-        err = GetLastError();
-        break;
-
-      default:
-        DEBUG_PRINT("Every worker is done");
-        break;
-    }
-  }
-  /* Nothing to monitor but some time to wait. */
-  else if (!hasStaticData)
-  {
-    Sleep(milliseconds);
-  }
-  leave_blocking_section();
-
-  DEBUG_PRINT("Error status: %d (0 is ok)", err);
-  /* Build results */
-  if (err == 0)
-  {
-    DEBUG_PRINT("Building result");
-    read_list = Val_unit; 
-    write_list = Val_unit;
-    except_list = Val_unit;
-
-    iterSelectData = lpSelectData;
-    while (iterSelectData != NULL)
-    {
-      for (i = 0; i < iterSelectData->nResultsCount; i++)
-      {
-        iterResult = &(iterSelectData->aResults[i]);
-        l = alloc_small(2, 0);
-        Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds));
-        switch (iterResult->EMode)
+      hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
+      
+      if (tm >= 0.0)
         {
-        case SELECT_MODE_READ:
-          Store_field(l, 1, read_list);
-          read_list = l;
-          break;
-        case SELECT_MODE_WRITE:
-          Store_field(l, 1, write_list);
-          write_list = l;
-          break;
-        case SELECT_MODE_EXCEPT:
-          Store_field(l, 1, except_list);
-          except_list = l;
-          break;
+          milliseconds = 1000 * tm;
+          DEBUG_PRINT("Will wait %d ms", milliseconds);
+        }
+      else
+        {
+          milliseconds = INFINITE;
+        }
+      
+      
+      /* Create list of select data, based on the different list of fd to watch */
+      DEBUG_PRINT("Dispatch read fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = readfds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+      
+      DEBUG_PRINT("Dispatch write fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = writefds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+      
+      DEBUG_PRINT("Dispatch exceptional fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+      
+      /* Building the list of handle to wait for */
+      DEBUG_PRINT("Building events done array");
+      nEventsMax   = list_length((LPLIST)lpSelectData);
+      nEventsCount = 0;
+      lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
+      
+      iterSelectData = lpSelectData;
+      while (iterSelectData != NULL)
+        {
+          /* Check if it is static data. If this is the case, launch everything
+           * but don't wait for events. It helps to test if there are events on
+           * any other fd (which are not static), knowing that there is at least
+           * one result (the static data).
+           */
+          if (iterSelectData->EType == SELECT_TYPE_STATIC)
+            {
+              hasStaticData = TRUE;
+            };
+          
+          /* Execute APC */
+          if (iterSelectData->funcWorker != NULL)
+            {
+              iterSelectData->lpWorker = 
+                worker_job_submit(
+                                  iterSelectData->funcWorker, 
+                                  (void *)iterSelectData);
+              DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); 
+              lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker);
+              nEventsCount++;
+            };
+          iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+        };
+      
+      DEBUG_PRINT("Need to watch %d workers", nEventsCount);
+      
+      /* Processing select itself */
+      enter_blocking_section();
+      /* There are worker started, waiting to be monitored */
+      if (nEventsCount > 0)
+        {
+          /* Waiting for event */
+          if (err == 0 && !hasStaticData)
+            {
+              DEBUG_PRINT("Waiting for one select worker to be done");
+              switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds))
+                {
+                case WAIT_FAILED:
+                  err = GetLastError();
+                  break;
+                  
+                case WAIT_TIMEOUT:
+                  DEBUG_PRINT("Select timeout");
+                  break;
+                  
+                default:
+                  DEBUG_PRINT("One worker is done");
+                  break;
+                };
+            }
+          
+          /* Ordering stop to every worker */
+          DEBUG_PRINT("Sending stop signal to every select workers");
+          iterSelectData = lpSelectData;
+          while (iterSelectData != NULL)
+            {
+              if (iterSelectData->lpWorker != NULL)
+                {
+                  worker_job_stop(iterSelectData->lpWorker);
+                };
+              iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+            };
+          
+          DEBUG_PRINT("Waiting for every select worker to be done");
+          switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE))
+            {
+            case WAIT_FAILED:
+              err = GetLastError();
+              break;
+              
+            default:
+              DEBUG_PRINT("Every worker is done");
+              break;
+            }
+        }
+      /* Nothing to monitor but some time to wait. */
+      else if (!hasStaticData)
+        {
+          Sleep(milliseconds);
+        }
+      leave_blocking_section();
+      
+      DEBUG_PRINT("Error status: %d (0 is ok)", err);
+      /* Build results */
+      if (err == 0)
+        {
+          DEBUG_PRINT("Building result");
+          read_list = Val_unit; 
+          write_list = Val_unit;
+          except_list = Val_unit;
+          
+          iterSelectData = lpSelectData;
+          while (iterSelectData != NULL)
+            {
+              for (i = 0; i < iterSelectData->nResultsCount; i++)
+                {
+                  iterResult = &(iterSelectData->aResults[i]);
+                  l = alloc_small(2, 0);
+                  Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds));
+                  switch (iterResult->EMode)
+                    {
+                    case SELECT_MODE_READ:
+                      Store_field(l, 1, read_list);
+                      read_list = l;
+                      break;
+                    case SELECT_MODE_WRITE:
+                      Store_field(l, 1, write_list);
+                      write_list = l;
+                      break;
+                    case SELECT_MODE_EXCEPT:
+                      Store_field(l, 1, except_list);
+                      except_list = l;
+                      break;
+                    }
+                }
+              /* We try to only process the first error, bypass other errors */
+              if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
+                {
+                  err = iterSelectData->nError;
+                }
+              iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+            }
+        }
+      
+      /* Free resources */
+      DEBUG_PRINT("Free selectdata resources");
+      iterSelectData = lpSelectData;
+      while (iterSelectData != NULL)
+        {
+          lpSelectData = iterSelectData;
+          iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+          select_data_free(lpSelectData);
+        }
+      lpSelectData = NULL;
+      
+      /* Free allocated events/handle set array */
+      DEBUG_PRINT("Free local allocated resources");
+      caml_stat_free(lpEventsDone);
+      caml_stat_free(hdsData);
+      
+      DEBUG_PRINT("Raise error if required");
+      if (err != 0)
+        {
+          win32_maperr(err);
+          uerror("select", Nothing);
         }
-      }
-      /* We try to only process the first error, bypass other errors */
-      if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
-      {
-        err = iterSelectData->nError;
-      }
-      iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
     }
   }
 
-  /* Free resources */
-  DEBUG_PRINT("Free selectdata resources");
-  iterSelectData = lpSelectData;
-  while (iterSelectData != NULL)
-  {
-    lpSelectData = iterSelectData;
-    iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
-    select_data_free(lpSelectData);
-  }
-  lpSelectData = NULL;
-  
-  /* Free allocated events/handle set array */
-  DEBUG_PRINT("Free local allocated resources");
-  caml_stat_free(lpEventsDone);
-  caml_stat_free(hdsData);
-
-  DEBUG_PRINT("Raise error if required");
-  if (err != 0)
-  {
-    win32_maperr(err);
-    uerror("select", Nothing);
-  }
-
   DEBUG_PRINT("Build final result");
   res = alloc_small(3, 0);
   Store_field(res, 0, read_list);
diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c
index 855957bd..0ee96c3d 100644
--- a/otherlibs/win32unix/sendrecv.c
+++ b/otherlibs/win32unix/sendrecv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -132,9 +132,7 @@ value unix_sendto_native(value sock, value buff, value ofs, value len, value fla
   return Val_int(ret);
 }
 
-CAMLprim value unix_sendto(argv, argc)
-     value * argv;
-     int argc;
+CAMLprim value unix_sendto(value * argv, int argc)
 {
   return unix_sendto_native
            (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c
index f3d2c6e0..dd4e7ed3 100644
--- a/otherlibs/win32unix/shutdown.c
+++ b/otherlibs/win32unix/shutdown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
index 421e5f90..68209672 100644
--- a/otherlibs/win32unix/sleep.c
+++ b/otherlibs/win32unix/sleep.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c
index 3cd55ec2..dc7a157c 100644
--- a/otherlibs/win32unix/socket.c
+++ b/otherlibs/win32unix/socket.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -17,7 +17,7 @@
 #include "unixsupport.h"
 
 int socket_domain_table[] = {
-  PF_UNIX, PF_INET
+  PF_UNIX, PF_INET /*, PF_INET6 */
 };
 
 int socket_type_table[] = {
@@ -28,25 +28,16 @@ CAMLprim value unix_socket(domain, type, proto)
      value domain, type, proto;
 {
   SOCKET s;
-  int oldvalue, oldvaluelen, newvalue, retcode;
 
-  oldvaluelen = sizeof(oldvalue);
-  retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-                       (char *) &oldvalue, &oldvaluelen);
-  if (retcode == 0) {
-    /* Set sockets to synchronous mode */
-    newvalue = SO_SYNCHRONOUS_NONALERT;
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &newvalue, sizeof(newvalue));
+  /* 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);
   }
+
   s = socket(socket_domain_table[Int_val(domain)],
                    socket_type_table[Int_val(type)],
                    Int_val(proto));
-  if (retcode == 0) {
-    /* Restore initial mode */
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &oldvalue, oldvaluelen);
-  }
   if (s == INVALID_SOCKET) {
     win32_maperr(WSAGetLastError());
     uerror("socket", Nothing);
diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h
index 8abc63b4..3d2c6675 100644
--- a/otherlibs/win32unix/socketaddr.h
+++ b/otherlibs/win32unix/socketaddr.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c
index f82d810e..94a6c040 100644
--- a/otherlibs/win32unix/sockopt.c
+++ b/otherlibs/win32unix/sockopt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c
index 8417e136..8d4def6c 100644
--- a/otherlibs/win32unix/startup.c
+++ b/otherlibs/win32unix/startup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
index 79fc3b2e..08ad397c 100644
--- a/otherlibs/win32unix/stat.c
+++ b/otherlibs/win32unix/stat.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c
index 51dc9bfb..8abfa6f8 100644
--- a/otherlibs/win32unix/system.c
+++ b/otherlibs/win32unix/system.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
new file mode 100644
index 00000000..725895ec
--- /dev/null
+++ b/otherlibs/win32unix/times.c
@@ -0,0 +1,35 @@
+#include 
+#include 
+#include "unixsupport.h"
+
+
+double to_sec(FILETIME ft) {
+  ULARGE_INTEGER tmp;
+
+  tmp.u.LowPart = ft.dwLowDateTime;
+  tmp.u.HighPart = ft.dwHighDateTime;
+
+  /* convert to seconds:
+     GetProcessTimes returns number of 100-nanosecond intervals */
+  return tmp.QuadPart / 1e7;
+}
+
+
+value unix_times(value unit) {
+
+  value res;
+  FILETIME creation, exit, stime, utime;
+
+  if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) {
+    win32_maperr(GetLastError());
+    uerror("times", Nothing);
+  }
+
+  res = alloc_small(4 * Double_wosize, Double_array_tag);
+  Store_double_field(res, 0, to_sec(utime));
+  Store_double_field(res, 1, to_sec(stime));
+  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 c8396d7f..19c27824 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -170,6 +170,7 @@ type open_flag =
   | O_DSYNC
   | O_SYNC
   | O_RSYNC
+  | O_SHARE_DELETE
 
 type file_perm = int
 
@@ -407,9 +408,7 @@ external localtime : float -> tm = "unix_localtime"
 external mktime : tm -> float * tm = "unix_mktime"
 let alarm n = invalid_arg "Unix.alarm not implemented"
 external sleep : int -> unit = "unix_sleep"
-let times () =
-  { tms_utime = Sys.time(); tms_stime = 0.0;
-    tms_cutime = 0.0; tms_cstime = 0.0 }
+external times: unit -> process_times = "unix_times"
 external utimes : string -> float -> float -> unit = "unix_utimes"
 
 type interval_timer =
diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index 2f545c19..f6431955 100644
--- a/otherlibs/win32unix/unixsupport.c
+++ b/otherlibs/win32unix/unixsupport.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -44,7 +44,8 @@ static struct custom_operations win_handle_ops = {
   win_handle_compare,
   win_handle_hash,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 value win_alloc_handle(HANDLE h)
@@ -53,7 +54,7 @@ value win_alloc_handle(HANDLE h)
   Handle_val(res) = h;
   Descr_kind_val(res) = KIND_HANDLE;
   CRT_fd_val(res) = NO_CRT_FD;
-  Flags_fd_val(res) = 0;
+  Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING;
   return res;
 }
 
@@ -63,7 +64,7 @@ value win_alloc_socket(SOCKET s)
   Socket_val(res) = s;
   Descr_kind_val(res) = KIND_SOCKET;
   CRT_fd_val(res) = NO_CRT_FD;
-  Flags_fd_val(res) = 0;
+  Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING;
   return res;
 }
 
diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h
index d5615830..f50d40c0 100644
--- a/otherlibs/win32unix/unixsupport.h
+++ b/otherlibs/win32unix/unixsupport.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
diff --git a/otherlibs/win32unix/windbug.c b/otherlibs/win32unix/windbug.c
index e3a2772d..0370d2de 100644
--- a/otherlibs/win32unix/windbug.c
+++ b/otherlibs/win32unix/windbug.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
index 69cbd3b6..efaeffc0 100644
--- a/otherlibs/win32unix/windbug.h
+++ b/otherlibs/win32unix/windbug.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
@@ -18,13 +18,15 @@
 #include 
 #include 
 
+/* 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:%d, tid: %d): ", GetCurrentProcessId(), GetCurrentThreadId()); \
-      fprintf(stderr, fmt, __VA_ARGS__); \
+      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 8b96589e..240b863b 100644
--- a/otherlibs/win32unix/windir.c
+++ b/otherlibs/win32unix/windir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*   Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt  */
 /*                                                                     */
diff --git a/otherlibs/win32unix/winlist.c b/otherlibs/win32unix/winlist.c
index 318a0add..bbb2e7cf 100644
--- a/otherlibs/win32unix/winlist.c
+++ b/otherlibs/win32unix/winlist.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
diff --git a/otherlibs/win32unix/winlist.h b/otherlibs/win32unix/winlist.h
index be388a4c..1f0a8435 100644
--- a/otherlibs/win32unix/winlist.h
+++ b/otherlibs/win32unix/winlist.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c
index 895a6926..db13231a 100644
--- a/otherlibs/win32unix/winwait.c
+++ b/otherlibs/win32unix/winwait.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*   Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt  */
 /*                                                                     */
diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c
index 57f95a9a..01c7dc40 100644
--- a/otherlibs/win32unix/winworker.c
+++ b/otherlibs/win32unix/winworker.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h
index 06450a4e..caf9067a 100644
--- a/otherlibs/win32unix/winworker.h
+++ b/otherlibs/win32unix/winworker.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
index 190d9025..46d75ccb 100644
--- a/otherlibs/win32unix/write.c
+++ b/otherlibs/win32unix/write.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/parsing/.cvsignore b/parsing/.cvsignore
deleted file mode 100644
index 5602bf8a..00000000
--- a/parsing/.cvsignore
+++ /dev/null
@@ -1,9 +0,0 @@
-parser.ml
-parser.mli
-lexer.ml
-lexer_tmp.mll
-lexer_tmp.ml
-linenum.ml
-parser.output
-parser.automaton
-parser.conflicts
diff --git a/parsing/.ignore b/parsing/.ignore
new file mode 100644
index 00000000..5602bf8a
--- /dev/null
+++ b/parsing/.ignore
@@ -0,0 +1,9 @@
+parser.ml
+parser.mli
+lexer.ml
+lexer_tmp.mll
+lexer_tmp.ml
+linenum.ml
+parser.output
+parser.automaton
+parser.conflicts
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index 2530b44c..d23a87fb 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 3ddb5dde..175eedc9 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 5da264ec..87e2a8cb 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -416,7 +416,7 @@ and comment = parse
   | "*)"
       { match !comment_start_loc with
         | [] -> assert false
-        | [x] -> comment_start_loc := [];
+        | [_] -> comment_start_loc := [];
         | _ :: l -> comment_start_loc := l;
                     comment lexbuf;
        }
diff --git a/parsing/linenum.mli b/parsing/linenum.mli
deleted file mode 100644
index 50cc57e8..00000000
--- a/parsing/linenum.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            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.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* An auxiliary lexer for determining the line number corresponding to
-   a file position, honoring the directives # linenum "filename" *)
-
-val for_position: string -> int -> string * int * int
-        (* [Linenum.for_position file loc] returns a triple describing
-           the location [loc] in the file named [file].
-           First result is name of actual source file.
-           Second result is line number in that source file.
-           Third result is position of beginning of that line in [file]. *)
diff --git a/parsing/linenum.mll b/parsing/linenum.mll
deleted file mode 100644
index 91e71e97..00000000
--- a/parsing/linenum.mll
+++ /dev/null
@@ -1,74 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            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.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* An auxiliary lexer for determining the line number corresponding to
-   a file position, honoring the directives # linenum "filename" *)
-
-{
-let filename = ref ""
-let linenum = ref 0
-let linebeg = ref 0
-
-let parse_sharp_line s =
-  try
-    (* Update the line number and file name *)
-    let l1 = ref 0 in
-    while let c = s.[!l1] in c < '0' || c > '9' do incr l1 done;
-    let l2 = ref (!l1 + 1) in
-    while let c = s.[!l2] in c >= '0' && c <= '9' do incr l2 done;
-    linenum := int_of_string(String.sub s !l1 (!l2 - !l1));
-    let f1 = ref (!l2 + 1) in
-    while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done;
-    let f2 = ref (!f1 + 1) in
-    while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done;
-    if !f1 < String.length s then
-      filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1)
-  with Failure _ | Invalid_argument _ ->
-    Misc.fatal_error "Linenum.parse_sharp_line"
-}
-
-rule skip_line = parse
-    "#" [' ' '\t']* ['0'-'9']+ [' ' '\t']*
-    ("\"" [^ '\n' '\r' '"' (* '"' *) ] * "\"")?
-    [^ '\n' '\r'] *
-    ('\n' | '\r' | "\r\n")
-      { parse_sharp_line(Lexing.lexeme lexbuf);
-        linebeg := Lexing.lexeme_start lexbuf;
-        Lexing.lexeme_end lexbuf }
-  | [^ '\n' '\r'] *
-    ('\n' | '\r' | "\r\n")
-      { incr linenum;
-        linebeg := Lexing.lexeme_start lexbuf;
-        Lexing.lexeme_end lexbuf }
-  | [^ '\n' '\r'] * eof
-      { incr linenum;
-        linebeg := Lexing.lexeme_start lexbuf;
-        raise End_of_file }
-
-{
-
-let for_position file loc =
-  let ic = open_in_bin file in
-  let lb = Lexing.from_channel ic in
-  filename := file;
-  linenum := 1;
-  linebeg := 0;
-  begin try
-    while skip_line lb <= loc do () done
-  with End_of_file -> ()
-  end;
-  close_in ic;
-  (!filename, !linenum - 1, !linebeg)
-
-}
diff --git a/parsing/location.ml b/parsing/location.ml
index 15b074ac..561a9060 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,9 +14,11 @@
 
 open Lexing
 
-type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
+let absname = ref false
+    (* This reference should be in Clflags, but it would create an additional
+       dependency and make bootstrapping Camlp4 more difficult. *)
 
-let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true };;
+type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
 
 let in_file name =
   let loc = {
@@ -28,6 +30,8 @@ let in_file name =
   { loc_start = loc; loc_end = loc; loc_ghost = true }
 ;;
 
+let none = in_file "_none_";;
+
 let curr lexbuf = {
   loc_start = lexbuf.lex_start_p;
   loc_end = lexbuf.lex_curr_p;
@@ -196,42 +200,57 @@ let rec highlight_locations ppf loc1 loc2 =
 
 open Format
 
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s = if is_relative s then concat (Sys.getcwd ()) s else s in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  if !absname then absolute_path file else file
+
+let print_filename ppf file =
+  Format.fprintf ppf "%s" (show_filename file)
+
 let reset () =
   num_loc_lines := 0
 
-let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
-  ("File \"", "\", line ", ", characters ", "-", ":", "")
+let (msg_file, msg_line, msg_chars, msg_to, msg_colon) =
+  ("File \"", "\", line ", ", characters ", "-", ":")
 
 (* return file, line, char from the given position *)
 let get_pos_info pos =
-  let (filename, linenum, linebeg) =
-    if pos.pos_fname = "" && !input_name = "" then
-      ("", -1, 0)
-    else if pos.pos_fname = "" then
-      Linenum.for_position !input_name pos.pos_cnum
-    else
-      (pos.pos_fname, pos.pos_lnum, pos.pos_bol)
-  in
-  (filename, linenum, pos.pos_cnum - linebeg)
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
 ;;
 
-let print ppf loc =
+let print_loc ppf loc =
   let (file, line, startchar) = get_pos_info loc.loc_start in
   let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
-  let (startchar, endchar) =
-    if startchar < 0 then (0, 1) else (startchar, endchar)
-  in
-  if file = "" then begin
+  if file = "//toplevel//" then begin
     if highlight_locations ppf loc none then () else
-      fprintf ppf "Characters %i-%i:@."
+      fprintf ppf "Characters %i-%i"
               loc.loc_start.pos_cnum loc.loc_end.pos_cnum
   end else begin
-    fprintf ppf "%s%s%s%i" msg_file file msg_line line;
-    fprintf ppf "%s%i" msg_chars startchar;
-    fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head;
+    fprintf ppf "%s%a%s%i" msg_file print_filename file msg_line line;
+    if startchar >= 0 then
+      fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar
   end
 ;;
 
+let print ppf loc =
+  if loc.loc_start.pos_fname = "//toplevel//"
+  && highlight_locations ppf loc none then ()
+  else fprintf ppf "%a%s@." print_loc loc msg_colon
+;;
+
 let print_error ppf loc =
   print ppf loc;
   fprintf ppf "Error: ";
@@ -245,7 +264,7 @@ let print_warning loc ppf w =
       let n = Warnings.print ppf w in
       num_loc_lines := !num_loc_lines + n
     in
-    fprintf ppf "%a" print loc;
+    print ppf loc;
     fprintf ppf "Warning %a@." printw w;
     pp_print_flush ppf ();
     incr num_loc_lines;
diff --git a/parsing/location.mli b/parsing/location.mli
index a496a355..2b1a5a8f 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -46,7 +46,8 @@ 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 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
@@ -55,3 +56,13 @@ val echo_eof: unit -> unit
 val reset: unit -> unit
 
 val highlight_locations: formatter -> t -> t -> bool
+
+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 --git a/parsing/longident.ml b/parsing/longident.ml
index 1b459ca3..612f9df1 100644
--- a/parsing/longident.ml
+++ b/parsing/longident.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,14 +20,14 @@ type t =
 let rec flat accu = function
     Lident s -> s :: accu
   | Ldot(lid, s) -> flat (s :: accu) lid
-  | Lapply(l1, l2) -> Misc.fatal_error "Longident.flat"
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
 
 let flatten lid = flat [] lid
 
 let last = function
     Lident s -> s
-  | Ldot(lid, s) -> s
-  | Lapply(l1, l2) -> Misc.fatal_error "Longident.last"
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
 
 let rec split_at_dots s pos =
   try
diff --git a/parsing/longident.mli b/parsing/longident.mli
index 4568bc95..a802049b 100644
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/parsing/parse.ml b/parsing/parse.ml
index 7f3e4cdc..cf862af3 100644
--- a/parsing/parse.ml
+++ b/parsing/parse.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -46,14 +46,14 @@ let wrap parsing_fun lexbuf =
   | Lexer.Error(Lexer.Unterminated_string, _) as err -> raise err
   | Lexer.Error(Lexer.Unterminated_string_in_comment, _) as err -> raise err
   | Lexer.Error(Lexer.Illegal_character _, _) as err ->
-      if !Location.input_name = "" then skip_phrase lexbuf;
+      if !Location.input_name = "//toplevel//" then skip_phrase lexbuf;
       raise err
   | Syntaxerr.Error _ as err ->
-      if !Location.input_name = "" then maybe_skip_phrase lexbuf;
+      if !Location.input_name = "//toplevel//" then maybe_skip_phrase lexbuf;
       raise err
   | Parsing.Parse_error | Syntaxerr.Escape_error ->
       let loc = Location.curr lexbuf in
-      if !Location.input_name = ""
+      if !Location.input_name = "//toplevel//"
       then maybe_skip_phrase lexbuf;
       raise(Syntaxerr.Error(Syntaxerr.Other loc))
 ;;
diff --git a/parsing/parse.mli b/parsing/parse.mli
index 87a09f0e..85e08bc4 100644
--- a/parsing/parse.mli
+++ b/parsing/parse.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 9311b34c..a5065b5c 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -47,9 +47,12 @@ let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
 let mkoperator name pos =
   { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos }
 
+let mkpatvar name pos =
+  { ppat_desc = Ppat_var name; ppat_loc = rhs_loc pos }
+
 (*
   Ghost expressions and patterns:
-  expressions and patterns that do not appear explicitely in the
+  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.
@@ -70,8 +73,9 @@ let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
 
 let mkassert e =
   match e with
-  | {pexp_desc = Pexp_construct (Lident "false", None, false) } ->
-         mkexp (Pexp_assertfalse)
+  | { pexp_desc = Pexp_construct (Lident "false", None, false);
+      pexp_loc = _ } ->
+      mkexp (Pexp_assertfalse)
   | _ -> mkexp (Pexp_assert (e))
 ;;
 
@@ -160,7 +164,7 @@ let bigarray_function str name =
   Ldot(Ldot(Lident "Bigarray", str), name)
 
 let bigarray_untuplify = function
-    { pexp_desc = Pexp_tuple explist} -> explist
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
   | exp -> [exp]
 
 let bigarray_get arr arg =
@@ -208,6 +212,68 @@ let exp_of_label lbl =
 let pat_of_label lbl =
   mkpat (Ppat_var(Longident.last lbl))
 
+let check_variable vl loc v =
+  if List.mem v vl then
+    raise Syntaxerr.(Error(Variable_in_scope(loc,v)))
+
+let varify_constructors var_names t =
+  let rec loop t =
+    let desc =
+      match t.ptyp_desc with
+      | Ptyp_any -> Ptyp_any
+      | Ptyp_var x ->
+          check_variable var_names t.ptyp_loc x;
+          Ptyp_var x
+      | Ptyp_arrow (label,core_type,core_type') ->
+          Ptyp_arrow(label, loop core_type, loop core_type')
+      | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+      | Ptyp_constr(Lident s, []) when List.mem s var_names ->
+          Ptyp_var s
+      | Ptyp_constr(longident, lst) ->
+          Ptyp_constr(longident, List.map loop lst)
+      | Ptyp_object lst ->
+          Ptyp_object (List.map loop_core_field lst)
+      | Ptyp_class (longident, lst, lbl_list) ->
+          Ptyp_class (longident, List.map loop lst, lbl_list)
+      | Ptyp_alias(core_type, string) ->
+          check_variable var_names t.ptyp_loc string;
+          Ptyp_alias(loop core_type, string)
+      | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+          Ptyp_variant(List.map loop_row_field row_field_list,
+                       flag, lbl_lst_option)
+      | Ptyp_poly(string_lst, core_type) ->
+          List.iter (check_variable var_names t.ptyp_loc) string_lst;
+          Ptyp_poly(string_lst, loop core_type)
+      | Ptyp_package(longident,lst) ->
+          Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+    in
+    {t with ptyp_desc = desc}
+  and loop_core_field t =
+    let desc =
+      match t.pfield_desc with
+      | Pfield(n,typ) ->
+          Pfield(n,loop typ)
+      | Pfield_var ->
+          Pfield_var
+    in
+    { t with pfield_desc=desc}
+  and loop_row_field  =
+    function
+      | Rtag(label,flag,lst) ->
+          Rtag(label,flag,List.map loop lst)
+      | Rinherit t ->
+          Rinherit (loop t)
+  in
+  loop t
+
+let wrap_type_annotation newtypes core_type body =
+  let exp = mkexp(Pexp_constraint(body,Some core_type,None)) in
+  let exp =
+    List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+      newtypes exp
+  in
+  (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
+
 %}
 
 /* Tokens */
@@ -453,10 +519,24 @@ module_expr:
       { $2 }
   | LPAREN module_expr error
       { unclosed "(" 1 ")" 3 }
+  | LPAREN VAL expr RPAREN
+      { mkmod(Pmod_unpack $3) }
   | LPAREN VAL expr COLON package_type RPAREN
-      { mkmod(Pmod_unpack($3, $5)) }
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)), None)))) }
+  | LPAREN VAL expr COLON package_type COLONGREATER package_type RPAREN
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)),
+                                    Some(ghtyp(Ptyp_package $7)))))) }
+  | LPAREN VAL expr COLONGREATER package_type RPAREN
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, None, Some(ghtyp(Ptyp_package $5)))))) }
   | LPAREN VAL expr COLON error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN VAL expr COLONGREATER error
+      { unclosed "(" 1 ")" 5 }
+  | LPAREN VAL expr error
+      { unclosed "(" 1 ")" 4 }
 ;
 structure:
     structure_tail                              { $1 }
@@ -472,7 +552,7 @@ structure_tail:
 structure_item:
     LET rec_flag let_bindings
       { match $3 with
-          [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
+          [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
         | _ -> mkstr(Pstr_value($2, List.rev $3)) }
   | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
       { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
@@ -702,6 +782,10 @@ concrete_method :
       { $4, $3, $2, ghexp(Pexp_poly ($5, None)), symbol_rloc () }
   | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr
       { $4, $3, $2, ghexp(Pexp_poly($8,Some $6)), symbol_rloc () }
+  | METHOD override_flag private_flag label COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let exp, poly = wrap_type_annotation $7 $9 $11 in
+        $4, $3, $2, ghexp(Pexp_poly(exp, Some poly)), symbol_rloc () }
 ;
 
 /* Class types */
@@ -1021,8 +1105,11 @@ simple_expr:
       { mkexp(Pexp_override []) }
   | simple_expr SHARP label
       { mkexp(Pexp_send($1, $3)) }
+  | LPAREN MODULE module_expr RPAREN
+      { mkexp (Pexp_pack $3) }
   | LPAREN MODULE module_expr COLON package_type RPAREN
-      { mkexp (Pexp_pack ($3, $5)) }
+      { mkexp (Pexp_constraint (ghexp (Pexp_pack $3),
+                                Some (ghtyp (Ptyp_package $5)), None)) }
   | LPAREN MODULE module_expr COLON error
       { unclosed "(" 1 ")" 5 }
 ;
@@ -1055,13 +1142,19 @@ let_bindings:
     let_binding                                 { [$1] }
   | let_bindings AND let_binding                { $3 :: $1 }
 ;
+
+lident_list:
+    LIDENT                            { [$1] }
+  | LIDENT lident_list                { $1 :: $2 }
+;
 let_binding:
     val_ident fun_binding
-      { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) }
+      { (mkpatvar $1 1, $2) }
   | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
-      { (ghpat(Ppat_constraint({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1},
-                               ghtyp(Ptyp_poly($3,$5)))),
-         $7) }
+      { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($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) }
   | pattern EQUAL seq_expr
       { ($1, $3) }
 ;
@@ -1191,6 +1284,12 @@ simple_pattern:
       { mkpat(Ppat_constraint($2, $4)) }
   | LPAREN pattern COLON core_type error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN MODULE UIDENT RPAREN
+      { mkpat(Ppat_unpack $3) }
+  | LPAREN MODULE UIDENT COLON package_type RPAREN
+      { mkpat(Ppat_constraint(mkpat(Ppat_unpack $3),ghtyp(Ptyp_package $5))) }
+  | LPAREN MODULE UIDENT COLON package_type error
+      { unclosed "(" 1 ")" 6 }
 ;
 
 pattern_comma_list:
@@ -1227,7 +1326,7 @@ type_declarations:
 ;
 
 type_declaration:
-    type_parameters LIDENT type_kind constraints
+    optional_type_parameters LIDENT type_kind constraints
       { let (params, variance) = List.split $1 in
         let (kind, private_flag, manifest) = $3 in
         ($2, {ptype_params = params;
@@ -1236,7 +1335,7 @@ type_declaration:
               ptype_private = private_flag;
               ptype_manifest = manifest;
               ptype_variance = variance;
-              ptype_loc = symbol_rloc()}) }
+              ptype_loc = symbol_rloc() }) }
 ;
 constraints:
         constraints CONSTRAINT constrain        { $3 :: $1 }
@@ -1262,6 +1361,22 @@ type_kind:
   | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE
       { (Ptype_record(List.rev $6), $4, Some $2) }
 ;
+optional_type_parameters:
+    /*empty*/                                   { [] }
+  | optional_type_parameter                              { [$1] }
+  | LPAREN optional_type_parameter_list RPAREN  { List.rev $2 }
+;
+optional_type_parameter:
+    type_variance QUOTE ident                   { Some $3, $1 }
+  | type_variance UNDERSCORE                    { None, $1 }
+;
+optional_type_parameter_list:
+    optional_type_parameter                              { [$1] }
+  | optional_type_parameter_list COMMA optional_type_parameter    { $3 :: $1 }
+;
+
+
+
 type_parameters:
     /*empty*/                                   { [] }
   | type_parameter                              { [$1] }
@@ -1284,12 +1399,27 @@ constructor_declarations:
   | constructor_declarations BAR constructor_declaration { $3 :: $1 }
 ;
 constructor_declaration:
-    constr_ident constructor_arguments          { ($1, $2, symbol_rloc()) }
+
+  | constr_ident generalized_constructor_arguments
+      { let arg_types,ret_type = $2 in
+        ($1, arg_types,ret_type, symbol_rloc()) }
 ;
+
 constructor_arguments:
     /*empty*/                                   { [] }
   | OF core_type_list                           { List.rev $2 }
 ;
+
+generalized_constructor_arguments:
+    /*empty*/                                   { ([],None) }
+  | OF core_type_list                           { (List.rev $2,None) }
+  | COLON core_type_list MINUSGREATER simple_core_type
+                                                { (List.rev $2,Some $4) }
+  | COLON simple_core_type                      { ([],Some $2) }
+;
+
+
+
 label_declarations:
     label_declaration                           { [$1] }
   | label_declarations SEMI label_declaration   { $3 :: $1 }
@@ -1307,7 +1437,7 @@ with_constraints:
 with_constraint:
     TYPE type_parameters label_longident with_type_binder core_type constraints
       { let params, variance = List.split $2 in
-        ($3, Pwith_type {ptype_params = params;
+        ($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;
@@ -1318,7 +1448,7 @@ with_constraint:
        functor applications in type path */
   | TYPE type_parameters label_longident COLONEQUAL core_type
       { let params, variance = List.split $2 in
-        ($3, Pwith_typesubst {ptype_params = params;
+        ($3, Pwith_typesubst {ptype_params = List.map (fun x -> Some x) params;
                               ptype_cstrs = [];
                               ptype_kind = Ptype_abstract;
                               ptype_manifest = Some $5;
@@ -1426,7 +1556,7 @@ package_type:
   | mty_longident WITH package_type_cstrs { ($1, $3) }
 ;
 package_type_cstr:
-    TYPE LIDENT EQUAL core_type { ($2, $4) }
+    TYPE label_longident EQUAL core_type { ($2, $4) }
 ;
 package_type_cstrs:
     package_type_cstr { [$1] }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 05f92bd0..663ae7c5 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -35,7 +35,7 @@ and core_type_desc =
   | Ptyp_poly of string list * core_type
   | Ptyp_package of package_type
 
-and package_type = Longident.t * (string * core_type) list
+and package_type = Longident.t * (Longident.t * core_type) list
 
 and core_field_type =
   { pfield_desc: core_field_desc;
@@ -79,6 +79,7 @@ and pattern_desc =
   | Ppat_constraint of pattern * core_type
   | Ppat_type of Longident.t
   | Ppat_lazy of pattern
+  | Ppat_unpack of string
 
 type expression =
   { pexp_desc: expression_desc;
@@ -116,7 +117,7 @@ and expression_desc =
   | Pexp_poly of expression * core_type option
   | Pexp_object of class_structure
   | Pexp_newtype of string * expression
-  | Pexp_pack of module_expr * package_type
+  | Pexp_pack of module_expr
   | Pexp_open of Longident.t * expression
 
 (* Value descriptions *)
@@ -128,7 +129,7 @@ and value_description =
 (* Type declarations *)
 
 and type_declaration =
-  { ptype_params: string list;
+  { ptype_params: string option list;
     ptype_cstrs: (core_type * core_type * Location.t) list;
     ptype_kind: type_kind;
     ptype_private: private_flag;
@@ -138,7 +139,8 @@ and type_declaration =
 
 and type_kind =
     Ptype_abstract
-  | Ptype_variant of (string * core_type list * Location.t) list
+  | Ptype_variant of
+      (string * core_type list * core_type option * Location.t) list
   | Ptype_record of
       (string * mutable_flag * core_type * Location.t) list
 
@@ -187,12 +189,13 @@ and class_structure = pattern * class_field list
 and class_field =
     Pcf_inher of override_flag * class_expr * string option
   | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
-  | Pcf_val of (string * mutable_flag * override_flag * expression * Location.t)
-  | Pcf_virt  of (string * private_flag * core_type * Location.t)
-  | Pcf_meth of (string * private_flag *override_flag * expression * Location.t)
-  | Pcf_cstr  of (core_type * core_type * Location.t)
-  | Pcf_let   of rec_flag * (pattern * expression) list * Location.t
-  | Pcf_init  of expression
+  | Pcf_val of
+      (string * mutable_flag * override_flag * expression * Location.t)
+  | Pcf_virt of (string * private_flag * core_type * Location.t)
+  | Pcf_meth of
+      (string * private_flag * override_flag * expression * Location.t)
+  | Pcf_cstr of (core_type * core_type * Location.t)
+  | Pcf_init of expression
 
 and class_declaration = class_expr class_infos
 
@@ -237,7 +240,7 @@ and with_constraint =
   | Pwith_typesubst of type_declaration
   | Pwith_modsubst of Longident.t
 
-(* value expressions for the module language *)
+(* Value expressions for the module language *)
 
 and module_expr =
   { pmod_desc: module_expr_desc;
@@ -249,7 +252,7 @@ and module_expr_desc =
   | Pmod_functor of string * module_type * module_expr
   | Pmod_apply of module_expr * module_expr
   | Pmod_constraint of module_expr * module_type
-  | Pmod_unpack of expression * package_type
+  | Pmod_unpack of expression
 
 and structure = structure_item list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index f63e21b8..d5b99331 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,9 +19,7 @@ open Location;;
 open Parsetree;;
 
 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
+  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)
@@ -98,7 +96,7 @@ let line i f s (*...*) =
 let list i f ppf l =
   match l with
   | [] -> line i ppf "[]\n";
-  | h::t ->
+  | _ :: _ ->
      line i ppf "[\n";
      List.iter (f (i+1) ppf) l;
      line i ppf "]\n";
@@ -154,10 +152,10 @@ let rec core_type i ppf x =
       core_type i ppf ct;
   | Ptyp_package (s, l) ->
       line i ppf "Ptyp_package %a\n" fmt_longident s;
-      list i package_with ppf l
+      list i package_with ppf l;
 
 and package_with i ppf (s, t) =
-  line i ppf "with type %s\n" s;
+  line i ppf "with type %a\n" fmt_longident s;
   core_type i ppf t
 
 and core_field_type i ppf x =
@@ -209,6 +207,8 @@ and pattern i ppf x =
   | Ppat_type li ->
       line i ppf "Ppat_type";
       longident i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack \"%s\"\n" s;
 
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;
@@ -321,9 +321,8 @@ and expression i ppf x =
   | Pexp_newtype (s, e) ->
       line i ppf "Pexp_newtype \"%s\"\n" s;
       expression i ppf e
-  | Pexp_pack (me, (p,l)) ->
-      line i ppf "Pexp_pack %a" fmt_longident p;
-      list i package_with ppf l;
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack";
       module_expr i ppf me
   | Pexp_open (m, e) ->
       line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
@@ -334,11 +333,18 @@ and value_description i ppf x =
   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
+    | None ->
+	string i ppf "_"
+
 and type_declaration i ppf x =
   line i ppf "type_declaration %a\n" fmt_location x.ptype_loc;
   let i = i+1 in
   line i ppf "ptype_params =\n";
-  list (i+1) string ppf x.ptype_params;
+  list (i+1) string_option_underscore ppf x.ptype_params;
   line i ppf "ptype_cstrs =\n";
   list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
   line i ppf "ptype_kind =\n";
@@ -483,9 +489,6 @@ and class_field i ppf x =
       line i ppf "Pcf_cstr %a\n" fmt_location loc;
       core_type (i+1) ppf ct1;
       core_type (i+1) ppf ct2;
-  | Pcf_let (rf, l, loc) ->
-      line i ppf "Pcf_let %a %a\n" fmt_rec_flag rf fmt_location loc;
-      list (i+1) pattern_x_expression_def ppf l;
   | Pcf_init (e) ->
       line i ppf "Pcf_init\n";
       expression (i+1) ppf e;
@@ -518,7 +521,7 @@ and module_type i ppf x =
       list i longident_x_with_constraint ppf l;
   | Pmty_typeof m ->
       line i ppf "Pmty_typeof\n";
-      module_expr i ppf m
+      module_expr i ppf m;
 
 and signature i ppf x = list i signature_item ppf x
 
@@ -593,9 +596,8 @@ and module_expr i ppf x =
       line i ppf "Pmod_constraint\n";
       module_expr i ppf me;
       module_type i ppf mt;
-  | Pmod_unpack (e, (p, l)) ->
-      line i ppf "Pmod_unpack %a\n" fmt_longident p;
-      list i package_with ppf l;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
       expression i ppf e;
 
 and structure i ppf x = list i structure_item ppf x
@@ -663,9 +665,10 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
   core_type (i+1) ppf ct1;
   core_type (i+1) ppf ct2;
 
-and string_x_core_type_list_x_location i ppf (s, l, loc) =
+and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) = 
   line i ppf "\"%s\" %a\n" s fmt_location loc;
   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 fmt_mutable_flag mf fmt_location loc;
diff --git a/parsing/printast.mli b/parsing/printast.mli
index 7ea14867..096f4617 100644
--- a/parsing/printast.mli
+++ b/parsing/printast.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index edaabda1..f18e3281 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,15 +19,17 @@ open Format
 type error =
     Unclosed of Location.t * string * 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
 
 let report_error ppf = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      if String.length !Location.input_name = 0
-      && Location.highlight_locations ppf opening_loc closing_loc
+      if !Location.input_name = "//toplevel//"
+         && Location.highlight_locations ppf opening_loc closing_loc
       then fprintf ppf "Syntax error: '%s' expected, \
                    the highlighted '%s' might be unmatched" closing opening
       else begin
@@ -37,7 +39,14 @@ let report_error ppf = function
           Location.print_error opening_loc opening
       end
   | Applicative_path loc ->
-      fprintf ppf "%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set."
+      fprintf ppf
+        "%aSyntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
         Location.print_error loc
+  | Variable_in_scope (loc, var) ->
+      fprintf ppf
+        "%a@[In this scoped type, variable '%s@ \
+         is reserved for the local type %s.@]"
+        Location.print_error loc var var
   | Other loc ->
       fprintf ppf "%aSyntax error" Location.print_error loc
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 4e967992..c2f9eb07 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,6 +19,7 @@ open Format
 type error =
     Unclosed of Location.t * string * Location.t * string
   | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
   | Other of Location.t
 
 exception Error of error
diff --git a/stdlib/.cvsignore b/stdlib/.cvsignore
deleted file mode 100644
index 6aa0cd42..00000000
--- a/stdlib/.cvsignore
+++ /dev/null
@@ -1,7 +0,0 @@
-camlheader
-camlheader_ur
-labelled-*
-caml
-*.annot
-sys.ml
-*.a
diff --git a/stdlib/.depend b/stdlib/.depend
index 0267136b..3fd2959b 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -1,248 +1,260 @@
-arg.cmi:
-array.cmi:
-arrayLabels.cmi:
-buffer.cmi:
-callback.cmi:
-camlinternalLazy.cmi:
-camlinternalMod.cmi: obj.cmi
-camlinternalOO.cmi: obj.cmi
-char.cmi:
-complex.cmi:
-digest.cmi:
-filename.cmi:
-format.cmi: pervasives.cmi buffer.cmi
-gc.cmi:
-genlex.cmi: stream.cmi
-hashtbl.cmi:
-int32.cmi:
-int64.cmi:
-lazy.cmi:
-lexing.cmi:
-list.cmi:
-listLabels.cmi:
-map.cmi:
-marshal.cmi:
-moreLabels.cmi: set.cmi map.cmi hashtbl.cmi
-nativeint.cmi:
-obj.cmi: int32.cmi
-oo.cmi: camlinternalOO.cmi
-parsing.cmi: obj.cmi lexing.cmi
-pervasives.cmi:
-printexc.cmi:
-printf.cmi: obj.cmi buffer.cmi
-queue.cmi:
-random.cmi: nativeint.cmi int64.cmi int32.cmi
-scanf.cmi: pervasives.cmi
-set.cmi:
-sort.cmi:
-stack.cmi:
-stdLabels.cmi:
-stream.cmi:
-string.cmi:
-stringLabels.cmi:
-sys.cmi:
-weak.cmi: hashtbl.cmi
-arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi
-arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi
-array.cmo: array.cmi
-array.cmx: array.cmi
-arrayLabels.cmo: array.cmi arrayLabels.cmi
-arrayLabels.cmx: array.cmx arrayLabels.cmi
-buffer.cmo: sys.cmi string.cmi buffer.cmi
-buffer.cmx: sys.cmx string.cmx buffer.cmi
-callback.cmo: obj.cmi callback.cmi
-callback.cmx: obj.cmx callback.cmi
-camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi
-camlinternalLazy.cmx: obj.cmx camlinternalLazy.cmi
-camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi
-camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi
-camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
-    array.cmi camlinternalOO.cmi
-camlinternalOO.cmx: sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
-    array.cmx camlinternalOO.cmi
-char.cmo: char.cmi
-char.cmx: char.cmi
-complex.cmo: complex.cmi
-complex.cmx: complex.cmi
-digest.cmo: string.cmi printf.cmi digest.cmi
-digest.cmx: string.cmx printf.cmx digest.cmi
-filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
+arg.cmi :
+array.cmi :
+arrayLabels.cmi :
+buffer.cmi :
+callback.cmi :
+camlinternalLazy.cmi :
+camlinternalMod.cmi : obj.cmi
+camlinternalOO.cmi : obj.cmi
+char.cmi :
+complex.cmi :
+digest.cmi :
+filename.cmi :
+format.cmi : pervasives.cmi buffer.cmi
+gc.cmi :
+genlex.cmi : stream.cmi
+hashtbl.cmi :
+int32.cmi :
+int64.cmi :
+lazy.cmi :
+lexing.cmi :
+list.cmi :
+listLabels.cmi :
+map.cmi :
+marshal.cmi :
+moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
+nativeint.cmi :
+obj.cmi : int32.cmi
+oo.cmi : camlinternalOO.cmi
+parsing.cmi : obj.cmi lexing.cmi
+pervasives.cmi :
+printexc.cmi :
+printf.cmi : obj.cmi buffer.cmi
+queue.cmi :
+random.cmi : nativeint.cmi int64.cmi int32.cmi
+scanf.cmi : pervasives.cmi
+set.cmi :
+sort.cmi :
+stack.cmi :
+stdLabels.cmi :
+stream.cmi :
+string.cmi :
+stringLabels.cmi :
+sys.cmi :
+weak.cmi : hashtbl.cmi
+arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
+    arg.cmi
+arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
+    arg.cmi
+array.cmo : array.cmi
+array.cmx : array.cmi
+arrayLabels.cmo : array.cmi arrayLabels.cmi
+arrayLabels.cmx : array.cmx arrayLabels.cmi
+buffer.cmo : sys.cmi string.cmi buffer.cmi
+buffer.cmx : sys.cmx string.cmx buffer.cmi
+callback.cmo : obj.cmi callback.cmi
+callback.cmx : obj.cmx callback.cmi
+camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
+camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+    camlinternalMod.cmi
+camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \
+    camlinternalMod.cmi
+camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
+    callback.cmi array.cmi camlinternalOO.cmi
+camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
+    callback.cmx array.cmx camlinternalOO.cmi
+char.cmo : char.cmi
+char.cmx : char.cmi
+complex.cmo : complex.cmi
+complex.cmx : complex.cmi
+digest.cmo : string.cmi printf.cmi char.cmi digest.cmi
+digest.cmx : string.cmx printf.cmx char.cmx digest.cmi
+filename.cmo : sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
     filename.cmi
-filename.cmx: sys.cmx string.cmx random.cmx printf.cmx buffer.cmx \
+filename.cmx : sys.cmx string.cmx random.cmx printf.cmx buffer.cmx \
     filename.cmi
-format.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi buffer.cmi \
-    format.cmi
-format.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx buffer.cmx \
-    format.cmi
-gc.cmo: sys.cmi printf.cmi gc.cmi
-gc.cmx: sys.cmx printf.cmx gc.cmi
-genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
-genlex.cmx: string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi
-hashtbl.cmo: sys.cmi array.cmi hashtbl.cmi
-hashtbl.cmx: sys.cmx array.cmx hashtbl.cmi
-int32.cmo: pervasives.cmi int32.cmi
-int32.cmx: pervasives.cmx int32.cmi
-int64.cmo: pervasives.cmi int64.cmi
-int64.cmx: pervasives.cmx int64.cmi
-lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi
-lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi
-lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi
-lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi
-list.cmo: list.cmi
-list.cmx: list.cmi
-listLabels.cmo: list.cmi listLabels.cmi
-listLabels.cmx: list.cmx listLabels.cmi
-map.cmo: map.cmi
-map.cmx: map.cmi
-marshal.cmo: string.cmi marshal.cmi
-marshal.cmx: string.cmx marshal.cmi
-moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi
-moreLabels.cmx: set.cmx map.cmx hashtbl.cmx moreLabels.cmi
-nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi
-nativeint.cmx: sys.cmx pervasives.cmx nativeint.cmi
-obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi
-obj.cmx: marshal.cmx int32.cmx array.cmx obj.cmi
-oo.cmo: camlinternalOO.cmi oo.cmi
-oo.cmx: camlinternalOO.cmx oo.cmi
-parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi
-parsing.cmx: obj.cmx lexing.cmx array.cmx parsing.cmi
-pervasives.cmo: pervasives.cmi
-pervasives.cmx: pervasives.cmi
-printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
-printexc.cmx: printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi
-printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
+format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    buffer.cmi format.cmi
+format.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \
+    buffer.cmx format.cmi
+gc.cmo : sys.cmi printf.cmi gc.cmi
+gc.cmx : sys.cmx printf.cmx gc.cmi
+genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
+genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi
+hashtbl.cmo : sys.cmi obj.cmi array.cmi hashtbl.cmi
+hashtbl.cmx : sys.cmx obj.cmx array.cmx hashtbl.cmi
+int32.cmo : pervasives.cmi int32.cmi
+int32.cmx : pervasives.cmx int32.cmi
+int64.cmo : pervasives.cmi int64.cmi
+int64.cmx : pervasives.cmx int64.cmi
+lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
+lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
+lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi
+lexing.cmx : sys.cmx string.cmx array.cmx lexing.cmi
+list.cmo : list.cmi
+list.cmx : list.cmi
+listLabels.cmo : list.cmi listLabels.cmi
+listLabels.cmx : list.cmx listLabels.cmi
+map.cmo : map.cmi
+map.cmx : map.cmi
+marshal.cmo : string.cmi marshal.cmi
+marshal.cmx : string.cmx marshal.cmi
+moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
+moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
+nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
+nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi
+obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi
+obj.cmx : marshal.cmx int32.cmx array.cmx obj.cmi
+oo.cmo : camlinternalOO.cmi oo.cmi
+oo.cmx : camlinternalOO.cmx oo.cmi
+parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
+parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
+pervasives.cmo : pervasives.cmi
+pervasives.cmx : pervasives.cmi
+printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
+printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi
+printf.cmo : string.cmi 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 \
+printf.cmx : string.cmx pervasives.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 \
+queue.cmo : obj.cmi queue.cmi
+queue.cmx : obj.cmx queue.cmi
+random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
     digest.cmi char.cmi array.cmi random.cmi
-random.cmx: string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
+random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
     digest.cmx char.cmx array.cmx random.cmi
-scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \
-    buffer.cmi array.cmi scanf.cmi
-scanf.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx hashtbl.cmx \
-    buffer.cmx array.cmx scanf.cmi
-set.cmo: set.cmi
-set.cmx: set.cmi
-sort.cmo: array.cmi sort.cmi
-sort.cmx: array.cmx sort.cmi
-stack.cmo: list.cmi stack.cmi
-stack.cmx: list.cmx stack.cmi
-stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi
-stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi
-std_exit.cmo:
-std_exit.cmx:
-stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
-stream.cmx: string.cmx obj.cmx list.cmx lazy.cmx stream.cmi
-string.cmo: pervasives.cmi list.cmi char.cmi string.cmi
-string.cmx: pervasives.cmx list.cmx char.cmx string.cmi
-stringLabels.cmo: string.cmi stringLabels.cmi
-stringLabels.cmx: string.cmx stringLabels.cmi
-sys.cmo: sys.cmi
-sys.cmx: sys.cmi
-weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
-weak.cmx: sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
-arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi
-arg.p.cmx: sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx arg.cmi
-array.cmo: array.cmi
-array.p.cmx: array.cmi
-arrayLabels.cmo: array.cmi arrayLabels.cmi
-arrayLabels.p.cmx: array.p.cmx arrayLabels.cmi
-buffer.cmo: sys.cmi string.cmi buffer.cmi
-buffer.p.cmx: sys.p.cmx string.p.cmx buffer.cmi
-callback.cmo: obj.cmi callback.cmi
-callback.p.cmx: obj.p.cmx callback.cmi
-camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi
-camlinternalLazy.p.cmx: obj.p.cmx camlinternalLazy.cmi
-camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi
-camlinternalMod.p.cmx: obj.p.cmx camlinternalOO.p.cmx array.p.cmx camlinternalMod.cmi
-camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
-    array.cmi camlinternalOO.cmi
-camlinternalOO.p.cmx: sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \
-    array.p.cmx camlinternalOO.cmi
-char.cmo: char.cmi
-char.p.cmx: char.cmi
-complex.cmo: complex.cmi
-complex.p.cmx: complex.cmi
-digest.cmo: string.cmi printf.cmi digest.cmi
-digest.p.cmx: string.p.cmx printf.p.cmx digest.cmi
-filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
+scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    hashtbl.cmi buffer.cmi array.cmi scanf.cmi
+scanf.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \
+    hashtbl.cmx buffer.cmx array.cmx scanf.cmi
+set.cmo : set.cmi
+set.cmx : set.cmi
+sort.cmo : array.cmi sort.cmi
+sort.cmx : array.cmx sort.cmi
+stack.cmo : list.cmi stack.cmi
+stack.cmx : list.cmx stack.cmi
+stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \
+    stdLabels.cmi
+stdLabels.cmx : stringLabels.cmx listLabels.cmx arrayLabels.cmx \
+    stdLabels.cmi
+std_exit.cmo :
+std_exit.cmx :
+stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
+stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx stream.cmi
+string.cmo : pervasives.cmi list.cmi char.cmi string.cmi
+string.cmx : pervasives.cmx list.cmx char.cmx string.cmi
+stringLabels.cmo : string.cmi stringLabels.cmi
+stringLabels.cmx : string.cmx stringLabels.cmi
+sys.cmo : sys.cmi
+sys.cmx : sys.cmi
+weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
+weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
+    arg.cmi
+arg.p.cmx : sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx \
+    arg.cmi
+array.cmo : array.cmi
+array.p.cmx : array.cmi
+arrayLabels.cmo : array.cmi arrayLabels.cmi
+arrayLabels.p.cmx : array.p.cmx arrayLabels.cmi
+buffer.cmo : sys.cmi string.cmi buffer.cmi
+buffer.p.cmx : sys.p.cmx string.p.cmx buffer.cmi
+callback.cmo : obj.cmi callback.cmi
+callback.p.cmx : obj.p.cmx callback.cmi
+camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
+camlinternalLazy.p.cmx : obj.p.cmx camlinternalLazy.cmi
+camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+    camlinternalMod.cmi
+camlinternalMod.p.cmx : obj.p.cmx camlinternalOO.p.cmx array.p.cmx \
+    camlinternalMod.cmi
+camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
+    callback.cmi array.cmi camlinternalOO.cmi
+camlinternalOO.p.cmx : sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \
+    callback.p.cmx array.p.cmx camlinternalOO.cmi
+char.cmo : char.cmi
+char.p.cmx : char.cmi
+complex.cmo : complex.cmi
+complex.p.cmx : complex.cmi
+digest.cmo : string.cmi printf.cmi char.cmi digest.cmi
+digest.p.cmx : string.p.cmx printf.p.cmx char.p.cmx digest.cmi
+filename.cmo : sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
     filename.cmi
-filename.p.cmx: sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx buffer.p.cmx \
+filename.p.cmx : sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx buffer.p.cmx \
     filename.cmi
-format.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi buffer.cmi \
-    format.cmi
-format.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx buffer.p.cmx \
-    format.cmi
-gc.cmo: sys.cmi printf.cmi gc.cmi
-gc.p.cmx: sys.p.cmx printf.p.cmx gc.cmi
-genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
-genlex.p.cmx: string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi
-hashtbl.cmo: sys.cmi array.cmi hashtbl.cmi
-hashtbl.p.cmx: sys.p.cmx array.p.cmx hashtbl.cmi
-int32.cmo: pervasives.cmi int32.cmi
-int32.p.cmx: pervasives.p.cmx int32.cmi
-int64.cmo: pervasives.cmi int64.cmi
-int64.p.cmx: pervasives.p.cmx int64.cmi
-lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi
-lazy.p.cmx: obj.p.cmx camlinternalLazy.p.cmx lazy.cmi
-lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi
-lexing.p.cmx: sys.p.cmx string.p.cmx array.p.cmx lexing.cmi
-list.cmo: list.cmi
-list.p.cmx: list.cmi
-listLabels.cmo: list.cmi listLabels.cmi
-listLabels.p.cmx: list.p.cmx listLabels.cmi
-map.cmo: map.cmi
-map.p.cmx: map.cmi
-marshal.cmo: string.cmi marshal.cmi
-marshal.p.cmx: string.p.cmx marshal.cmi
-moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi
-moreLabels.p.cmx: set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi
-nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi
-nativeint.p.cmx: sys.p.cmx pervasives.p.cmx nativeint.cmi
-obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi
-obj.p.cmx: marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi
-oo.cmo: camlinternalOO.cmi oo.cmi
-oo.p.cmx: camlinternalOO.p.cmx oo.cmi
-parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi
-parsing.p.cmx: obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi
-pervasives.cmo: pervasives.cmi
-pervasives.p.cmx: pervasives.cmi
-printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
-printexc.p.cmx: printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi
-printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
+format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    buffer.cmi format.cmi
+format.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \
+    buffer.p.cmx format.cmi
+gc.cmo : sys.cmi printf.cmi gc.cmi
+gc.p.cmx : sys.p.cmx printf.p.cmx gc.cmi
+genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
+genlex.p.cmx : string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi
+hashtbl.cmo : sys.cmi obj.cmi array.cmi hashtbl.cmi
+hashtbl.p.cmx : sys.p.cmx obj.p.cmx array.p.cmx hashtbl.cmi
+int32.cmo : pervasives.cmi int32.cmi
+int32.p.cmx : pervasives.p.cmx int32.cmi
+int64.cmo : pervasives.cmi int64.cmi
+int64.p.cmx : pervasives.p.cmx int64.cmi
+lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
+lazy.p.cmx : obj.p.cmx camlinternalLazy.p.cmx lazy.cmi
+lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi
+lexing.p.cmx : sys.p.cmx string.p.cmx array.p.cmx lexing.cmi
+list.cmo : list.cmi
+list.p.cmx : list.cmi
+listLabels.cmo : list.cmi listLabels.cmi
+listLabels.p.cmx : list.p.cmx listLabels.cmi
+map.cmo : map.cmi
+map.p.cmx : map.cmi
+marshal.cmo : string.cmi marshal.cmi
+marshal.p.cmx : string.p.cmx marshal.cmi
+moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
+moreLabels.p.cmx : set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi
+nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
+nativeint.p.cmx : sys.p.cmx pervasives.p.cmx nativeint.cmi
+obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi
+obj.p.cmx : marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi
+oo.cmo : camlinternalOO.cmi oo.cmi
+oo.p.cmx : camlinternalOO.p.cmx oo.cmi
+parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
+parsing.p.cmx : obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi
+pervasives.cmo : pervasives.cmi
+pervasives.p.cmx : pervasives.cmi
+printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
+printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi
+printf.cmo : string.cmi 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 \
+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
-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 \
+queue.cmo : obj.cmi queue.cmi
+queue.p.cmx : obj.p.cmx queue.cmi
+random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
     digest.cmi char.cmi array.cmi random.cmi
-random.p.cmx: string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \
+random.p.cmx : string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \
     digest.p.cmx char.p.cmx array.p.cmx random.cmi
-scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \
-    buffer.cmi array.cmi scanf.cmi
-scanf.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx hashtbl.p.cmx \
-    buffer.p.cmx array.p.cmx scanf.cmi
-set.cmo: set.cmi
-set.p.cmx: set.cmi
-sort.cmo: array.cmi sort.cmi
-sort.p.cmx: array.p.cmx sort.cmi
-stack.cmo: list.cmi stack.cmi
-stack.p.cmx: list.p.cmx stack.cmi
-stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi
-stdLabels.p.cmx: stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx stdLabels.cmi
-std_exit.cmo:
-std_exit.p.cmx:
-stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
-stream.p.cmx: string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi
-string.cmo: pervasives.cmi list.cmi char.cmi string.cmi
-string.p.cmx: pervasives.p.cmx list.p.cmx char.p.cmx string.cmi
-stringLabels.cmo: string.cmi stringLabels.cmi
-stringLabels.p.cmx: string.p.cmx stringLabels.cmi
-sys.cmo: sys.cmi
-sys.p.cmx: sys.cmi
-weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
-weak.p.cmx: sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi
+scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    hashtbl.cmi buffer.cmi array.cmi scanf.cmi
+scanf.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \
+    hashtbl.p.cmx buffer.p.cmx array.p.cmx scanf.cmi
+set.cmo : set.cmi
+set.p.cmx : set.cmi
+sort.cmo : array.cmi sort.cmi
+sort.p.cmx : array.p.cmx sort.cmi
+stack.cmo : list.cmi stack.cmi
+stack.p.cmx : list.p.cmx stack.cmi
+stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \
+    stdLabels.cmi
+stdLabels.p.cmx : stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx \
+    stdLabels.cmi
+std_exit.cmo :
+std_exit.p.cmx :
+stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
+stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi
+string.cmo : pervasives.cmi list.cmi char.cmi string.cmi
+string.p.cmx : pervasives.p.cmx list.p.cmx char.p.cmx string.cmi
+stringLabels.cmo : string.cmi stringLabels.cmi
+stringLabels.p.cmx : string.p.cmx stringLabels.cmi
+sys.cmo : sys.cmi
+sys.p.cmx : sys.cmi
+weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
+weak.p.cmx : sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi
diff --git a/stdlib/.ignore b/stdlib/.ignore
new file mode 100644
index 00000000..ad1b04e1
--- /dev/null
+++ b/stdlib/.ignore
@@ -0,0 +1,6 @@
+camlheader
+camlheaderd
+camlheader_ur
+labelled-*
+caml
+sys.ml
diff --git a/stdlib/Compflags b/stdlib/Compflags
index 862a1c4e..80bb1b66 100755
--- a/stdlib/Compflags
+++ b/stdlib/Compflags
@@ -1,7 +1,7 @@
 #!/bin/sh
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                OCaml                                  #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -18,6 +18,7 @@ case $1 in
   pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
   camlinternalOO.cmi) echo ' -nopervasives';;
   camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  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';;
   listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';;
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 874dcf6f..2c8e0670 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -42,9 +42,10 @@ installopt-prof:
 stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
 	$(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx)
 
-camlheader camlheader_ur: header.c ../config/Makefile
+camlheader camlheaderd camlheader_ur: header.c ../config/Makefile
 	if $(SHARPBANGSCRIPTS); then \
 	  echo '#!$(BINDIR)/ocamlrun' > camlheader && \
+	  echo '#!$(BINDIR)/ocamlrund' > camlheaderd && \
 	  echo '#!' | tr -d '\012' > camlheader_ur; \
 	else \
 	  $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
@@ -52,7 +53,12 @@ camlheader camlheader_ur: header.c ../config/Makefile
 	            header.c -o tmpheader$(EXE) && \
 	  strip tmpheader$(EXE) && \
 	  mv tmpheader$(EXE) camlheader && \
-	  cp camlheader camlheader_ur; \
+	  cp camlheader camlheader_ur && \
+	  $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+	            -DRUNTIME_NAME='"$(BINDIR)/ocamlrund"' \
+	            header.c -o tmpheader$(EXE) && \
+	  strip tmpheader$(EXE) && \
+	  mv tmpheader$(EXE) camlheaderd; \
 	fi
 
 .PHONY: all allopt allopt-noprof allopt-prof install installopt
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
index 995a0c3f..579391a7 100644
--- a/stdlib/Makefile.nt
+++ b/stdlib/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -21,11 +21,18 @@ installopt:
 	cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR)
 
 camlheader camlheader_ur: headernt.c ../config/Makefile
-	$(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun headernt.c
+	$(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+	          -DRUNTIME_NAME='"ocamlrun"' headernt.c
 	$(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
 	rm -f camlheader.exe
 	mv tmpheader.exe camlheader
 	cp camlheader camlheader_ur
 
+camlheaderd: headernt.c ../config/Makefile
+	$(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+	          -DRUNTIME_NAME='"ocamlrund"' headernt.c
+	$(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+	mv tmpheader.exe camlheaderd
+
 # TODO: do not call flexlink to build tmpheader.exe (we don't need
 # the export table)
diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index 64087dc9..0752a1b5 100755
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -40,8 +40,16 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
 
 all: stdlib.cma std_exit.cmo camlheader camlheader_ur
 
-install:
-	cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR)
+install: install-$(RUNTIMED)
+	cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \
+	  $(LIBDIR)
+
+install-noruntimed:
+.PHONY: install-noruntimed
+
+install-runtimed: camlheaderd
+	cp camlheaderd $(LIBDIR)
+.PHONY: install-runtimed
 
 stdlib.cma: $(OBJS)
 	$(CAMLC) -a -o stdlib.cma $(OBJS)
@@ -56,7 +64,7 @@ clean::
 	rm -f sys.ml
 
 clean::
-	rm -f camlheader camlheader_ur
+	rm -f camlheader camlheader_ur camlheaderd
 
 .SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
 
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 4f689f8c..926e2cb5 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -1,7 +1,23 @@
-# This file lists all standard library modules. -*- Makefile -*-
-# It is used in particular to know what to expunge in toplevels.
+# -*- Makefile -*-
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2002 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
 # $Id$
 
+# This file lists all standard library modules.
+# It is used in particular to know what to expunge in toplevels.
+
 STDLIB_MODULES=\
   arg \
   array \
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index ac552d38..8453058e 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -64,10 +64,11 @@ let make_symlist prefix sep suffix l =
 ;;
 
 let print_spec buf (key, spec, doc) =
-  match spec with
-  | Symbol (l, _) -> bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l)
-                             doc
-  | _ -> bprintf buf "  %s %s\n" key 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
 ;;
 
 let help_action () = raise (Stop (Unknown "-help"));;
@@ -237,6 +238,10 @@ let max_arg_len cur (kwd, spec, doc) =
 
 let add_padding len ksd =
   match ksd with
+  | (_, _, "") ->
+      (* Do not pad undocumented options, so that they still don't show up when
+       * run through [usage] or [parse]. *)
+      ksd
   | (kwd, (Symbol (l, _) as spec), msg) ->
       let cutcol = second_word msg in
       let spaces = String.make (len - cutcol + 3) ' ' in
diff --git a/stdlib/arg.mli b/stdlib/arg.mli
index 88725661..d6e0210a 100644
--- a/stdlib/arg.mli
+++ b/stdlib/arg.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -83,6 +83,8 @@ val parse :
 -   The reason for the error: unknown option, invalid or missing argument, etc.
 -   [usage_msg]
 -   The list of options, each followed by the corresponding [doc] string.
+    Beware: options that have an empty [doc] string will not be included in the
+    list.
 
     For the user to be able to specify anonymous arguments starting with a
     [-], include for example [("-", String anon_fun, doc)] in [speclist].
diff --git a/stdlib/array.ml b/stdlib/array.ml
index d1cbd655..076a3af0 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                           OCaml                                     *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,6 +22,10 @@ external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
 external make: int -> 'a -> 'a array = "caml_make_vect"
 external create: int -> 'a -> 'a array = "caml_make_vect"
+external 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"
 
 let init l f =
   if l = 0 then [||] else
@@ -41,58 +45,13 @@ let make_matrix sx sy init =
 let create_matrix = make_matrix
 
 let copy a =
-  let l = length a in
-  if l = 0 then [||] else begin
-    let res = create l (unsafe_get a 0) in
-    for i = 1 to pred l do
-      unsafe_set res i (unsafe_get a i)
-    done;
-    res
-  end
+  let l = length a in if l = 0 then [||] else sub a 0 l
 
 let append a1 a2 =
-  let l1 = length a1 and l2 = length a2 in
-  if l1 = 0 && l2 = 0 then [||] else begin
-    let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in
-    for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;
-    for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;
-    r
-  end
-
-let concat_aux init al =
-  let rec size accu = function
-    | [] -> accu
-    | h::t -> size (accu + length h) t
-  in
-  let res = create (size 0 al) init in
-  let rec fill pos = function
-    | [] -> ()
-    | h::t ->
-        for i = 0 to length h - 1 do
-          unsafe_set res (pos + i) (unsafe_get h i);
-        done;
-        fill (pos + length h) t;
-  in
-  fill 0 al;
-  res
-;;
-
-let concat al =
-  let rec find_init aa =
-    match aa with
-    | [] -> [||]
-    | a :: rem ->
-        if length a > 0 then concat_aux (unsafe_get a 0) aa else find_init rem
-  in find_init al
-
-let sub a ofs len =
-  if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Array.sub"
-  else if len = 0 then [||]
-  else begin
-    let r = create len (unsafe_get a ofs) in
-    for i = 1 to len - 1 do unsafe_set r i (unsafe_get a (ofs + i)) done;
-    r
-  end
+  let l1 = length a1 in
+  if l1 = 0 then copy a2
+  else if length a2 = 0 then sub a1 0 l1
+  else append_prim a1 a2
 
 let fill a ofs len v =
   if ofs < 0 || len < 0 || ofs > length a - len
@@ -103,16 +62,7 @@ let blit a1 ofs1 a2 ofs2 len =
   if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
              || ofs2 < 0 || ofs2 > length a2 - len
   then invalid_arg "Array.blit"
-  else if ofs1 < ofs2 then
-    (* Top-down copy *)
-    for i = len - 1 downto 0 do
-      unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
-    done
-  else
-    (* Bottom-up copy *)
-    for i = 0 to len - 1 do
-      unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
-    done
+  else unsafe_blit a1 ofs1 a2 ofs2 len
 
 let iter f a =
   for i = 0 to length a - 1 do f(unsafe_get a i) done
diff --git a/stdlib/array.mli b/stdlib/array.mli
index 9fb74b06..db1f469d 100644
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -201,5 +201,7 @@ val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
 (**/**)
 (** {6 Undocumented functions} *)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
diff --git a/stdlib/arrayLabels.ml b/stdlib/arrayLabels.ml
index fed0ad1c..652f4cac 100644
--- a/stdlib/arrayLabels.ml
+++ b/stdlib/arrayLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
index f45f70c6..308bfa4e 100644
--- a/stdlib/arrayLabels.mli
+++ b/stdlib/arrayLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -205,5 +205,7 @@ val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
 
 (** {6 Undocumented functions} *)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index 9327aaef..541717ad 100644
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*   Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt  *)
 (*                                                                     *)
diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
index efe2e9ea..ce70c983 100644
--- a/stdlib/buffer.mli
+++ b/stdlib/buffer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
diff --git a/stdlib/callback.ml b/stdlib/callback.ml
index 819f9d3f..5dd78948 100644
--- a/stdlib/callback.ml
+++ b/stdlib/callback.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -13,7 +13,7 @@
 
 (* $Id$ *)
 
-(* Registering Caml values with the C runtime for later callbacks *)
+(* Registering OCaml values with the C runtime for later callbacks *)
 
 external register_named_value : string -> Obj.t -> unit
                               = "caml_register_named_value"
diff --git a/stdlib/callback.mli b/stdlib/callback.mli
index ba2ab7ec..c536bf8d 100644
--- a/stdlib/callback.mli
+++ b/stdlib/callback.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -13,11 +13,11 @@
 
 (* $Id$ *)
 
-(** Registering Caml values with the C runtime.
+(** Registering OCaml values with the C runtime.
 
-   This module allows Caml values to be registered with the C runtime
+   This module allows OCaml values to be registered with the C runtime
    under a symbolic name, so that C code can later call back registered
-   Caml functions, or raise registered Caml exceptions.
+   OCaml functions, or raise registered OCaml exceptions.
 *)
 
 val register : string -> 'a -> unit
@@ -30,5 +30,5 @@ val register_exception : string -> exn -> unit
    exception contained in the exception value [exn]
    under the name [n]. C code can later retrieve a handle to
    the exception by calling [caml_named_value(n)]. The exception
-   value thus obtained is suitable for passign as first argument
+   value thus obtained is suitable for passing as first argument
    to [raise_constant] or [raise_with_arg]. *)
diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
index 46cf4278..042a377c 100644
--- a/stdlib/camlinternalLazy.ml
+++ b/stdlib/camlinternalLazy.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli
index 37b707d4..eef1c9d6 100644
--- a/stdlib/camlinternalLazy.mli
+++ b/stdlib/camlinternalLazy.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -13,7 +13,9 @@
 
 (* $Id$ *)
 
-(* Internals of forcing lazy values *)
+(** Run-time support for lazy values.
+    All functions in this module are for system use only, not for the
+    casual user. *)
 
 exception Undefined;;
 
diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index 12a77cc8..36d73bdc 100644
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            *)
 (*                                                                     *)
diff --git a/stdlib/camlinternalMod.mli b/stdlib/camlinternalMod.mli
index 74bf28db..bc59f195 100644
--- a/stdlib/camlinternalMod.mli
+++ b/stdlib/camlinternalMod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            *)
 (*                                                                     *)
@@ -13,6 +13,10 @@
 
 (* $Id$ *)
 
+(** Run-time support for recursive modules.
+    All functions in this module are for system use only, not for the
+    casual user. *)
+
 type shape =
   | Function
   | Lazy
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 2ffa71c0..6d787146 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,8 +18,7 @@ open Obj
 (**** Object representation ****)
 
 let last_id = ref 0
-let new_id () =
-  let id = !last_id in incr last_id; id
+let () = Callback.register "CamlinternalOO.last_id" last_id
 
 let set_id o id =
   let id0 = !id in
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index d2aeea31..f02b0203 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/char.ml b/stdlib/char.ml
index 28a1bcc4..6dafbad2 100644
--- a/stdlib/char.ml
+++ b/stdlib/char.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/char.mli b/stdlib/char.mli
index 8ab72bd9..05a8156d 100644
--- a/stdlib/char.mli
+++ b/stdlib/char.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,7 +26,7 @@ val chr : int -> char
 val escaped : char -> string
 (** Return a string representing the given character,
    with special characters escaped following the lexical conventions
-   of Objective Caml. *)
+   of OCaml. *)
 
 val lowercase : char -> char
 (** Convert the given character to its equivalent lowercase character. *)
@@ -45,4 +45,6 @@ val compare: t -> t -> int
 
 (**/**)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_chr : int -> char = "%identity"
diff --git a/stdlib/complex.ml b/stdlib/complex.ml
index 3c28a58b..c52e647c 100644
--- a/stdlib/complex.ml
+++ b/stdlib/complex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/complex.mli b/stdlib/complex.mli
index 3c3b361d..1bfa8b7b 100644
--- a/stdlib/complex.mli
+++ b/stdlib/complex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/digest.ml b/stdlib/digest.ml
index 78a45d54..38df61a0 100644
--- a/stdlib/digest.ml
+++ b/stdlib/digest.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -17,6 +17,8 @@
 
 type t = string
 
+let compare = String.compare
+
 external unsafe_string: string -> int -> int -> t = "caml_md5_string"
 external channel: in_channel -> int -> t = "caml_md5_chan"
 
@@ -48,4 +50,19 @@ let to_hex d =
     String.blit (Printf.sprintf "%02x" (int_of_char d.[i])) 0 result (2*i) 2;
   done;
   result
-;;
+
+let from_hex s =
+  if String.length s <> 32 then raise (Invalid_argument "Digest.from_hex");
+  let digit c =
+    match c with
+    | '0'..'9' -> Char.code c - Char.code '0'
+    | 'A'..'F' -> Char.code c - Char.code 'A' + 10
+    | 'a'..'f' -> Char.code c - Char.code 'a' + 10
+    | _ -> raise (Invalid_argument "Digest.from_hex")
+  in
+  let byte i = digit s.[i] lsl 4 + digit s.[i+1] in
+  let result = String.create 16 in
+  for i = 0 to 15 do
+    result.[i] <- Char.chr (byte (2 * i));
+  done;
+  result
diff --git a/stdlib/digest.mli b/stdlib/digest.mli
index 981bd02f..efc0a477 100644
--- a/stdlib/digest.mli
+++ b/stdlib/digest.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,12 +18,23 @@
    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.
+   that digest. The algorithm used is MD5. This module should not be
+   used for secure and sensitive cryptographic applications. For these
+   kind of applications more recent and stronger cryptographic
+   primitives should be used instead.
 *)
 
 type t = string
 (** The type of digests: 16-character strings. *)
 
+val compare : t -> t -> int
+(** The comparison function for 16-character digest, with the same
+    specification as {!Pervasives.compare} and the implementation
+    shared with {!String.compare}. Along with the type [t], this
+    function [compare] allows the module [Digest] to be passed as
+    argument to the functors {!Set.Make} and {!Map.Make}.
+    @since 4.00.0 *)
+
 val string : string -> t
 (** Return the digest of the given string. *)
 
@@ -51,3 +62,9 @@ val input : in_channel -> t
 
 val to_hex : t -> string
 (** Return the printable hexadecimal representation of the given digest. *)
+
+val from_hex : string -> t
+(** Convert a hexadecimal representation back into the corresponding digest.
+   Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal
+   characters.
+   @since 4.00.0 *)
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index e11f1e33..3c147333 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -25,30 +25,55 @@ let generic_quote quotequote s =
   Buffer.add_char b '\'';
   Buffer.contents b
 
-let generic_basename rindex_dir_sep current_dir_name name =
-  let raw_name =
-    try
-      let p = rindex_dir_sep name + 1 in
-      String.sub name p (String.length name - p)
-    with Not_found ->
-      name
+(* This function implements the Open Group specification found here:
+  [[1]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/basename.html
+  In step 1 of [[1]], we choose to return "." for empty input.
+    (for compatibility with previous versions of OCaml)
+  In step 2, we choose to process "//" normally.
+  Step 6 is not implemented: we consider that the [suffix] operand is
+    always absent.  Suffixes are handled by [chop_suffix] and [chop_extension].
+*)
+let generic_basename is_dir_sep current_dir_name name =
+  let rec find_end n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then find_end (n - 1)
+    else find_beg n (n + 1)
+  and find_beg n p =
+    if n < 0 then String.sub name 0 p
+    else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1)
+    else find_beg (n - 1) p
   in
-  if raw_name = "" then current_dir_name else raw_name
-
-let generic_dirname rindex_dir_sep current_dir_name dir_sep name =
-  try
-    match rindex_dir_sep name with
-      0 -> dir_sep
-    | n -> String.sub name 0 n
-  with Not_found ->
-    current_dir_name
+  if name = ""
+  then current_dir_name
+  else find_end (String.length name - 1)
+
+(* This function implements the Open Group specification found here:
+  [[2]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/dirname.html
+  In step 6 of [[2]], we choose to process "//" normally.
+*)
+let generic_dirname is_dir_sep current_dir_name name =
+  let rec trailing_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then trailing_sep (n - 1)
+    else base n
+  and base n =
+    if n < 0 then current_dir_name
+    else if is_dir_sep name n then intermediate_sep n
+    else base (n - 1)
+  and intermediate_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then intermediate_sep (n - 1)
+    else String.sub name 0 (n + 1)
+  in
+  if name = ""
+  then current_dir_name
+  else trailing_sep (String.length name - 1)
 
 module Unix = struct
   let current_dir_name = "."
   let parent_dir_name = ".."
   let dir_sep = "/"
   let is_dir_sep s i = s.[i] = '/'
-  let rindex_dir_sep s = String.rindex s '/'
   let is_relative n = String.length n < 1 || n.[0] <> '/';;
   let is_implicit n =
     is_relative n
@@ -61,8 +86,8 @@ module Unix = struct
   let temp_dir_name =
     try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
   let quote = generic_quote "'\\''"
-  let basename = generic_basename rindex_dir_sep current_dir_name
-  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
 end
 
 module Win32 = struct
@@ -70,12 +95,6 @@ module Win32 = struct
   let parent_dir_name = ".."
   let dir_sep = "\\"
   let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
-  let rindex_dir_sep s =
-    let rec pos i =
-      if i < 0 then raise Not_found
-      else if is_dir_sep s i then i
-      else pos (i - 1)
-    in pos (String.length s - 1)
   let is_relative n =
     (String.length n < 1 || n.[0] <> '/')
     && (String.length n < 1 || n.[0] <> '\\')
@@ -129,11 +148,11 @@ module Win32 = struct
     else ("", s)
   let dirname s =
     let (drive, path) = drive_and_path s in
-    let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in
+    let dir = generic_dirname is_dir_sep current_dir_name path in
     drive ^ dir
   let basename s =
     let (drive, path) = drive_and_path s in
-    generic_basename rindex_dir_sep current_dir_name path
+    generic_basename is_dir_sep current_dir_name path
 end
 
 module Cygwin = struct
@@ -141,33 +160,32 @@ module Cygwin = struct
   let parent_dir_name = ".."
   let dir_sep = "/"
   let is_dir_sep = Win32.is_dir_sep
-  let rindex_dir_sep = Win32.rindex_dir_sep
   let is_relative = Win32.is_relative
   let is_implicit = Win32.is_implicit
   let check_suffix = Win32.check_suffix
   let temp_dir_name = Unix.temp_dir_name
   let quote = Unix.quote
-  let basename = generic_basename rindex_dir_sep current_dir_name
-  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
 end
 
-let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
      is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
      dirname) =
   match Sys.os_type with
     "Unix" ->
       (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
-       Unix.is_dir_sep, Unix.rindex_dir_sep,
+       Unix.is_dir_sep,
        Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
        Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
   | "Win32" ->
       (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
-       Win32.is_dir_sep, Win32.rindex_dir_sep,
+       Win32.is_dir_sep,
        Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
        Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname)
   | "Cygwin" ->
       (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
-       Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
+       Cygwin.is_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
        Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
   | _ -> assert false
@@ -199,7 +217,12 @@ let temp_file_name temp_dir prefix suffix =
   concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
 ;;
 
-let temp_file ?(temp_dir=temp_dir_name) prefix suffix =
+let current_temp_dir_name = ref temp_dir_name
+
+let set_temp_dir_name s = current_temp_dir_name := s
+let get_temp_dir_name () = !current_temp_dir_name
+
+let temp_file ?(temp_dir = !current_temp_dir_name) prefix suffix =
   let rec try_name counter =
     let name = temp_file_name temp_dir prefix suffix in
     try
@@ -209,7 +232,7 @@ let temp_file ?(temp_dir=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=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 efbdcd98..499e8bb2 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -59,17 +59,19 @@ val chop_extension : string -> string
 
 val basename : string -> string
 (** Split a file name into directory name / base file name.
-   [concat (dirname name) (basename name)] returns a file name
-   which is equivalent to [name]. Moreover, after setting the
-   current directory to [dirname name] (with {!Sys.chdir}),
+   If [name] is a valid file name, then [concat (dirname name) (basename name)]
+   returns a file name which is equivalent to [name]. Moreover,
+   after setting the current directory to [dirname name] (with {!Sys.chdir}),
    references to [basename name] (which is a relative file name)
    designate the same file as [name] before the call to {!Sys.chdir}.
 
-   The result is not specified if the argument is not a valid file name
-   (for example, under Unix if there is a NUL character in the string). *)
+   This function conforms to the specification of POSIX.1-2008 for the
+   [basename] utility. *)
 
 val dirname : string -> string
-(** See {!Filename.basename}. *)
+(** See {!Filename.basename}.
+   This function conforms to the specification of POSIX.1-2008 for the
+   [dirname] utility. *)
 
 val temp_file : ?temp_dir: string -> string -> string -> string
 (** [temp_file prefix suffix] returns the name of a
@@ -77,7 +79,7 @@ val temp_file : ?temp_dir: string -> string -> string -> string
    The base name of the temporary file is formed by concatenating
    [prefix], then a suitably chosen integer number, then [suffix].
    The optional argument [temp_dir] indicates the temporary directory
-   to use, defaulting to {!Filename.temp_dir_name}.
+   to use, defaulting to the current result of {!Filename.get_temp_dir_name}.
    The temporary file is created empty, with permissions [0o600]
    (readable and writable only by the file owner).  The file is
    guaranteed to be different from any other file that existed when
@@ -100,12 +102,30 @@ val open_temp_file :
    @before 3.11.2 no ?temp_dir optional argument
 *)
 
-val temp_dir_name : string
+val get_temp_dir_name : unit -> string
 (** The name of the temporary directory:
     Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
     if the variable is not set.
     Under Windows, the value of the [TEMP] environment variable, or "."
     if the variable is not set.
+    The temporary directory can be changed with {!Filename.set_temp_dir_name}.
+    @since 4.00.0
+*)
+
+val set_temp_dir_name : string -> unit
+(** Change the temporary directory returned by {!Filename.get_temp_dir_name}
+    and used by {!Filename.temp_file} and {!Filename.open_temp_file}.
+    @since 4.00.0
+*)
+
+val temp_dir_name : string
+(** @deprecated  The name of the initial temporary directory:
+    Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
+    if the variable is not set.
+    Under Windows, the value of the [TEMP] environment variable, or "."
+    if the variable is not set.
+    This function is deprecated; {!Filename.get_temp_dir_name} should be
+    used instead.
     @since 3.09.1
 *)
 
diff --git a/stdlib/format.ml b/stdlib/format.ml
index a8d6ec9e..28bb5f1c 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -60,7 +60,8 @@ and block_type =
                when it leads to a new indentation of the current line *)
 | Pp_fits   (* Internal usage: when a block fits on a single line *)
 
-and tblock = Pp_tbox of int list ref  (* Tabulation box *)
+and tblock =
+  | Pp_tbox of int list ref  (* Tabulation box *)
 ;;
 
 (* The Queue:
@@ -182,28 +183,30 @@ let clear_queue q = q.insert <- Nil; q.body <- Nil;;
 let add_queue x q =
   let c = Cons { head = x; tail = Nil; } in
   match q with
-  | { insert = Cons cell } ->
+  | { insert = Cons cell; body = _; } ->
     q.insert <- c; cell.tail <- c
   (* Invariant: when insert is Nil body should be Nil. *)
-  | _ -> q.insert <- c; q.body <- c;;
+  | { insert = Nil; body = _; } ->
+    q.insert <- c; q.body <- c
+;;
 
 exception Empty_queue;;
 
 let peek_queue = function
-  | { body = Cons { head = x; }; } -> x
-  | _ -> raise Empty_queue
+  | { body = Cons { head = x; tail = _; }; _ } -> x
+  | { body = Nil; insert = _; } -> raise Empty_queue
 ;;
 
 let take_queue = function
-  | { body = Cons { head = x; tail = tl; }; } as q ->
+  | { body = Cons { head = x; tail = tl; }; _ } as q ->
     q.body <- tl;
     if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *)
     x
-  | _ -> raise Empty_queue
+  | { body = Nil; insert = _; } -> raise Empty_queue
 ;;
 
 (* Enter a token in the pretty-printer queue. *)
-let pp_enqueue state ({length = len} as token) =
+let pp_enqueue state ({ length = len; _} as token) =
   state.pp_right_total <- state.pp_right_total + len;
   add_queue token state.pp_queue
 ;;
@@ -272,15 +275,16 @@ let pp_force_break_line state =
     if width > state.pp_space_left then
       (match bl_ty with
        | Pp_fits -> () | Pp_hbox -> ()
-       | _ -> break_line state width)
-  | _ -> pp_output_newline state
+       | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box ->
+         break_line state width)
+  | [] -> pp_output_newline state
 ;;
 
 (* To skip a token, if the previous line has been broken. *)
 let pp_skip_token state =
   (* When calling pp_skip_token the queue cannot be empty. *)
   match take_queue state.pp_queue with
-  | { elem_size = size; length = len; } ->
+  | { elem_size = size; length = len; token = _; } ->
     state.pp_left_total <- state.pp_left_total - len;
     state.pp_space_left <- state.pp_space_left + int_of_size size
 ;;
@@ -308,15 +312,16 @@ let format_pp_token state size = function
     let bl_type =
       begin match ty with
       | Pp_vbox -> Pp_vbox
-      | _ -> if size > state.pp_space_left then ty else Pp_fits
+      | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits ->
+        if size > state.pp_space_left then ty else Pp_fits
       end in
     state.pp_format_stack <-
       Format_elem (bl_type, offset) :: state.pp_format_stack
 
   | Pp_end ->
     begin match state.pp_format_stack with
-    | x :: (y :: l as ls) -> state.pp_format_stack <- ls
-    | _ -> () (* No more block to close. *)
+    | _ :: ls -> state.pp_format_stack <- ls
+    | [] -> () (* No more block to close. *)
     end
 
   | Pp_tbegin (Pp_tbox _ as tbox) ->
@@ -324,8 +329,8 @@ let format_pp_token state size = function
 
   | Pp_tend ->
     begin match state.pp_tbox_stack with
-    | x :: ls -> state.pp_tbox_stack <- ls
-    | _ -> () (* No more tabulation block to close. *)
+    | _ :: ls -> state.pp_tbox_stack <- ls
+    | [] -> () (* No more tabulation block to close. *)
     end
 
   | Pp_stab ->
@@ -335,7 +340,7 @@ let format_pp_token state size = function
         | [] -> [n]
         | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in
       tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs
-    | _ -> () (* No opened tabulation block. *)
+    | [] -> () (* No opened tabulation block. *)
     end
 
   | Pp_tbreak (n, off) ->
@@ -347,7 +352,7 @@ let format_pp_token state size = function
         | [] -> raise Not_found in
       let tab =
         match !tabs with
-        | x :: l ->
+        | x :: _ ->
           begin
             try find insertion_point !tabs with
             | Not_found -> x
@@ -357,13 +362,13 @@ let format_pp_token state size = function
       if offset >= 0
       then break_same_line state (offset + n)
       else break_new_line state (tab + off) state.pp_margin
-    | _ -> () (* No opened tabulation block. *)
+    | [] -> () (* No opened tabulation block. *)
     end
 
   | Pp_newline ->
     begin match state.pp_format_stack with
     | Format_elem (_, width) :: _ -> break_line state width
-    | _ -> pp_output_newline state
+    | [] -> pp_output_newline state (* No opened block. *)
     end
 
   | Pp_if_newline ->
@@ -392,7 +397,7 @@ let format_pp_token state size = function
       | Pp_vbox -> break_new_line state off width
       | Pp_hbox -> break_same_line state n
       end
-    | _ -> () (* No opened block. *)
+    | [] -> () (* No opened block. *)
     end
 
    | Pp_open_tag tag_name ->
@@ -406,7 +411,7 @@ let format_pp_token state size = function
        let marker = state.pp_mark_close_tag tag_name in
        pp_output_string state marker;
        state.pp_mark_stack <- tags
-     | _ -> () (* No more tag to close. *)
+     | [] -> () (* No more tag to close. *)
      end
 ;;
 
@@ -474,7 +479,7 @@ let set_size state ty =
   match state.pp_scan_stack with
   | Scan_elem
       (left_tot,
-       ({elem_size = size; token = tok} as queue_elem)) :: t ->
+       ({ elem_size = size; token = tok; length = _; } as queue_elem)) :: t ->
     let size = int_of_size size in
     (* test if scan stack contains any data that is not obsolete. *)
     if left_tot < state.pp_left_total then clear_scan_stack state else
@@ -491,9 +496,12 @@ let set_size state ty =
           queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
           state.pp_scan_stack <- t
         end
-      | _ -> () (* scan_push is only used for breaks and boxes. *)
+      | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end
+      | Pp_newline | Pp_if_newline
+      | Pp_open_tag _ | Pp_close_tag ->
+        () (* scan_push is only used for breaks and boxes. *)
       end
-  | _ -> () (* scan_stack is never empty. *)
+  | [] -> () (* scan_stack is never empty. *)
 ;;
 
 (* Push a token on scan stack. If b is true set_size is called. *)
@@ -847,7 +855,7 @@ 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 s = ();;
+let default_pp_print_open_tag _ = ();;
 let default_pp_print_close_tag = default_pp_print_open_tag;;
 
 let pp_make_formatter f g h i =
@@ -1011,11 +1019,12 @@ module Tformat = Printf.CamlinternalPr.Tformat;;
 
 (* Trailer: giving up at character number ... *)
 let giving_up mess fmt i =
-  "fprintf: " ^ mess ^ " ``" ^ Sformat.to_string fmt ^ "'', \
-   giving up at character number " ^ string_of_int i ^
-  (if i < Sformat.length fmt
-   then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")."
-   else String.make 1 '.')
+  Printf.sprintf
+    "Format.fprintf: %s ``%s'', giving up at character number %d%s"
+    mess (Sformat.to_string fmt) i
+    (if i < Sformat.length fmt
+     then Printf.sprintf " (%c)." (Sformat.get fmt i)
+     else Printf.sprintf "%c" '.')
 ;;
 
 (* When an invalid format deserves a special error explanation. *)
@@ -1028,11 +1037,11 @@ let invalid_format fmt i = format_invalid_arg "bad format" fmt i;;
 let invalid_integer fmt i =
   invalid_arg (giving_up "bad integer specification" fmt i);;
 
-(* Finding an integer out of a sub-string of the format. *)
+(* Finding an integer size out of a sub-string of the format. *)
 let format_int_of_string fmt i s =
   let sz =
     try int_of_string s with
-    | Failure s -> invalid_integer fmt i in
+    | Failure _ -> invalid_integer fmt i in
   size_of_int sz
 ;;
 
@@ -1110,7 +1119,7 @@ let mkprintf to_s get_out =
           | '[' ->
             do_pp_open_box ppf n (succ i)
           | ']' ->
-             pp_close_box ppf ();
+            pp_close_box ppf ();
             doprn n (succ i)
           | '{' ->
             do_pp_open_tag ppf n (succ i)
@@ -1139,10 +1148,10 @@ let mkprintf to_s get_out =
               print_as := Some size;
               doprn n (skip_gt i) in
             get_int n (succ i) got_size
-          | '@' as c ->
+          | '@' | '%' as c ->
             pp_print_as_char c;
             doprn n (succ i)
-          | c -> invalid_format fmt i
+          | _ -> invalid_format fmt i
           end
         | c ->
           pp_print_as_char c;
@@ -1173,10 +1182,10 @@ let mkprintf to_s get_out =
         | ' ' -> 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
+          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 =
@@ -1185,7 +1194,7 @@ let mkprintf to_s get_out =
             | '0' .. '9' | '-' -> get (succ j)
             | _ ->
               let size =
-              if j = i then size_of_int 0 else
+                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
@@ -1215,7 +1224,7 @@ let mkprintf to_s get_out =
                  ("bad box name ho" ^ String.make 1 c) fmt i
              end
            | 'v' -> Pp_hvbox, succ i
-           | c -> Pp_hbox, i
+           | _ -> Pp_hbox, i
            end
         | 'b' -> Pp_box, succ i
         | 'v' -> Pp_vbox, succ i
@@ -1249,12 +1258,12 @@ let mkprintf to_s get_out =
                 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 =
+            and cont_f _n i =
               format_invalid_arg "bad tag name specification" fmt i
-            and cont_m n sfmt 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
-          | c -> get accu n i (succ j) in
+          | _ -> get accu n i (succ j) in
         get [] n i i
 
       and do_pp_break ppf n i =
@@ -1267,7 +1276,7 @@ let mkprintf to_s get_out =
             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
+        | _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
@@ -1278,7 +1287,7 @@ let mkprintf to_s get_out =
             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
+        | _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
@@ -1288,7 +1297,7 @@ let mkprintf to_s get_out =
             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
+        | _c -> pp_open_tag ppf ""; doprn n i in
 
       doprn (Sformat.index_of_int 0) 0 in
 
diff --git a/stdlib/format.mli b/stdlib/format.mli
index 9b49c53f..4831fe02 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -22,7 +22,8 @@
 
    For a gentle introduction to the basics of pretty-printing using
    [Format], read
-   {{:http://caml.inria.fr/resources/doc/guides/format.html}http://caml.inria.fr/resources/doc/guides/format.html}.
+   {{:http://caml.inria.fr/resources/doc/guides/format.en.html}
+    http://caml.inria.fr/resources/doc/guides/format.en.html}.
 
    You may consider this module as providing an extension to the
    [printf] facility to provide automatic line breaking. The addition of
@@ -404,7 +405,7 @@ val get_all_formatter_output_functions :
    including line breaking and indentation functions. Useful to record the
    current setting and restore it afterwards. *)
 
-(** {6:tags Changing the meaning of printing semantics tags} *)
+(** {6:tagsmeaning Changing the meaning of printing semantics tags} *)
 
 type formatter_tag_functions = {
   mark_open_tag : tag -> string;
@@ -617,7 +618,7 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
    - [@.]: flush the pretty printer and output a new line, as with
      [print_newline ()].
    - [@]: print the following item as if it were of length [n].
-     Hence, [printf "@<0>%s" arg] is equivalent to [print_as 0 arg].
+     Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string.
      If [@] is not followed by a conversion specification,
      then the following character of the format is printed as if
      it were of length [n].
@@ -631,12 +632,19 @@ 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.
-   - [@@]: print a plain [@] character.
+   - [@%]: print a plain [%] 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.
+
 *)
 
 val printf : ('a, formatter, unit) format -> 'a;;
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index 6482ebb7..16a354a3 100644
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 33e794dc..45d882f2 100644
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -123,6 +123,8 @@ type control =
        compaction is triggered at the end of each major GC cycle
        (this setting is intended for testing purposes only).
        If [max_overhead >= 1000000], compaction is never triggered.
+       If compaction is permanently disabled, it is strongly suggested
+       to set [allocation_policy] to 1.
        Default: 500. *)
 
     mutable stack_limit : int;
@@ -141,7 +143,7 @@ type control =
 (** The GC parameters are given as a [control] record.  Note that
     these parameters can also be initialised by setting the
     OCAMLRUNPARAM environment variable.  See the documentation of
-    ocamlrun. *)
+    [ocamlrun]. *)
 
 external stat : unit -> stat = "caml_gc_stat"
 (** Return the current values of the memory management counters in a
@@ -156,7 +158,7 @@ external quick_stat : unit -> stat = "caml_gc_quick_stat"
 
 external counters : unit -> float * float * float = "caml_gc_counters"
 (** Return [(minor_words, promoted_words, major_words)].  This function
-    is as fast at [quick_stat]. *)
+    is as fast as [quick_stat]. *)
 
 external get : unit -> control = "caml_gc_get"
 (** Return the current values of the GC parameters in a [control] record. *)
@@ -221,7 +223,7 @@ val finalise : ('a -> unit) -> 'a -> unit
    - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ]
 
 
-   The [f] function can use all features of O'Caml, including
+   The [f] function can use all features of OCaml, including
    assignments that make the value reachable again.  It can also
    loop forever (in this case, the other
    finalisation functions will not be called during the execution of f,
diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
index 6ecc2805..1c6276c9 100644
--- a/stdlib/genlex.ml
+++ b/stdlib/genlex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
 (*                                                                     *)
diff --git a/stdlib/genlex.mli b/stdlib/genlex.mli
index 93bc5f55..b1098f09 100644
--- a/stdlib/genlex.mli
+++ b/stdlib/genlex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
 (*                                                                     *)
@@ -18,7 +18,7 @@
 
    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 Caml, but is parameterized by the
+   roughly the lexical conventions of OCaml, but is parameterized by the
    set of keywords of your language.
 
 
@@ -37,6 +37,11 @@
                   [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
                 | ...
    ]}
+
+   One should notice that the use of the [parser] keyword and associated
+   notation for streams are only available through camlp4 extensions. This
+   means that one has to preprocess its sources {i e. g.} by using the
+   ["-pp"] command-line switch of the compilers.
 *)
 
 (** The type of tokens. The lexical classes are: [Int] and [Float]
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index bcb2c927..6f3ea880 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -15,24 +15,33 @@
 
 (* Hash tables *)
 
-external 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 = hash_param 10 100 x
+let hash x = seeded_hash_param 10 100 0 x
+let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
+let seeded_hash seed x = seeded_hash_param 10 100 seed x
 
 (* We do dynamic hashing, and resize the table and rehash the elements
    when buckets become too long. *)
 
 type ('a, 'b) t =
-  { mutable size: int;                        (* number of elements *)
-    mutable data: ('a, 'b) bucketlist array } (* the buckets *)
+  { mutable size: int;                        (* number of entries *)
+    mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
+    mutable seed: int }                       (* for randomization *)
 
 and ('a, 'b) bucketlist =
     Empty
   | Cons of 'a * 'b * ('a, 'b) bucketlist
 
-let create initial_size =
-  let s = min (max 1 initial_size) Sys.max_array_length in
-  { size = 0; data = Array.make s Empty }
+let rec power_2_above x n =
+  if x >= n then x
+  else if x * 2 > Sys.max_array_length then x
+  else power_2_above (x * 2) n
+
+let create ?(seed = 0) initial_size =
+  let s = power_2_above 16 initial_size in
+  { size = 0; seed = seed; data = Array.make s Empty }
 
 let clear h =
   for i = 0 to Array.length h.data - 1 do
@@ -40,94 +49,98 @@ let clear h =
   done;
   h.size <- 0
 
-let copy h =
-  { size = h.size;
-    data = Array.copy h.data }
+let copy h = { h with data = Array.copy h.data }
 
 let length h = h.size
 
-let resize hashfun tbl =
-  let odata = tbl.data in
+let resize indexfun h =
+  let odata = h.data in
   let osize = Array.length odata in
-  let nsize = min (2 * osize + 1) Sys.max_array_length in
-  if nsize <> osize then begin
+  let nsize = osize * 2 in
+  if nsize < Sys.max_array_length then begin
     let ndata = Array.create nsize Empty in
+    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
     let rec insert_bucket = function
         Empty -> ()
       | Cons(key, data, rest) ->
           insert_bucket rest; (* preserve original order of elements *)
-          let nidx = (hashfun key) mod nsize in
+          let nidx = indexfun h key in
           ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
     for i = 0 to osize - 1 do
       insert_bucket odata.(i)
-    done;
-    tbl.data <- ndata;
+    done
   end
 
+let key_index h key =
+  (* compatibility with old hash tables *)
+  if Obj.size (Obj.repr h) = 3
+  then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
+  else (old_hash_param 10 100 key) mod (Array.length h.data)
+
 let add h key info =
-  let i = (hash key) mod (Array.length h.data) in
+  let i = key_index h key in
   let bucket = Cons(key, info, h.data.(i)) in
   h.data.(i) <- bucket;
-  h.size <- succ h.size;
-  if h.size > Array.length h.data lsl 1 then resize hash h
+  h.size <- h.size + 1;
+  if h.size > Array.length h.data lsl 1 then resize key_index h
 
 let remove h key =
   let rec remove_bucket = function
-      Empty ->
+    | Empty ->
         Empty
     | Cons(k, i, next) ->
         if compare k key = 0
-        then begin h.size <- pred h.size; next end
+        then begin h.size <- h.size - 1; next end
         else Cons(k, i, remove_bucket next) in
-  let i = (hash key) mod (Array.length h.data) in
+  let i = key_index h key in
   h.data.(i) <- remove_bucket h.data.(i)
 
 let rec find_rec key = function
-    Empty ->
+  | Empty ->
       raise Not_found
   | Cons(k, d, rest) ->
       if compare key k = 0 then d else find_rec key rest
 
 let find h key =
-  match h.data.((hash key) mod (Array.length h.data)) with
-    Empty -> raise Not_found
+  match h.data.(key_index h key) with
+  | Empty -> raise Not_found
   | Cons(k1, d1, rest1) ->
       if compare key k1 = 0 then d1 else
       match rest1 with
-        Empty -> raise Not_found
+      | Empty -> raise Not_found
       | Cons(k2, d2, rest2) ->
           if compare key k2 = 0 then d2 else
           match rest2 with
-            Empty -> raise Not_found
+          | Empty -> raise Not_found
           | Cons(k3, d3, rest3) ->
               if compare key k3 = 0 then d3 else find_rec key rest3
 
 let find_all h key =
   let rec find_in_bucket = function
-    Empty ->
+  | Empty ->
       []
   | Cons(k, d, rest) ->
       if compare k key = 0
       then d :: find_in_bucket rest
       else find_in_bucket rest in
-  find_in_bucket h.data.((hash key) mod (Array.length h.data))
+  find_in_bucket h.data.(key_index h key)
 
 let replace h key info =
   let rec replace_bucket = function
-      Empty ->
+    | Empty ->
         raise Not_found
     | Cons(k, i, next) ->
         if compare k key = 0
-        then Cons(k, info, next)
+        then Cons(key, info, next)
         else Cons(k, i, replace_bucket next) in
-  let i = (hash key) mod (Array.length h.data) in
+  let i = key_index h key in
   let l = h.data.(i) in
   try
     h.data.(i) <- replace_bucket l
   with Not_found ->
     h.data.(i) <- Cons(key, info, l);
-    h.size <- succ h.size;
-    if h.size > Array.length h.data lsl 1 then resize hash h
+    h.size <- h.size + 1;
+    if h.size > Array.length h.data lsl 1 then resize key_index h
 
 let mem h key =
   let rec mem_in_bucket = function
@@ -135,11 +148,11 @@ let mem h key =
       false
   | Cons(k, d, rest) ->
       compare k key = 0 || mem_in_bucket rest in
-  mem_in_bucket h.data.((hash key) mod (Array.length h.data))
+  mem_in_bucket h.data.(key_index h key)
 
 let iter f h =
   let rec do_bucket = function
-      Empty ->
+    | Empty ->
         ()
     | Cons(k, d, rest) ->
         f k d; do_bucket rest in
@@ -162,6 +175,31 @@ let fold f h init =
   done;
   !accu
 
+type statistics = {
+  num_bindings: int;
+  num_buckets: int;
+  max_bucket_length: int;
+  bucket_histogram: int array
+}
+
+let rec bucket_length accu = function
+  | Empty -> accu
+  | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+
+let stats h =
+  let mbl =
+    Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
+  let histo = Array.make (mbl + 1) 0 in
+  Array.iter
+    (fun b ->
+      let l = bucket_length 0 b in
+      histo.(l) <- histo.(l) + 1)
+    h.data;
+  { num_bindings = h.size;
+    num_buckets = Array.length h.data;
+    max_bucket_length = mbl;
+    bucket_histogram = histo }
+
 (* Functorial interface *)
 
 module type HashedType =
@@ -171,6 +209,13 @@ module type HashedType =
     val hash: t -> int
   end
 
+module type SeededHashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val hash: int -> t -> int
+  end
+
 module type S =
   sig
     type key
@@ -187,9 +232,29 @@ module type S =
     val iter: (key -> 'a -> unit) -> 'a t -> unit
     val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val length: 'a t -> int
+    val stats: 'a t -> statistics
   end
 
-module Make(H: HashedType): (S with type key = H.t) =
+module type SeededS =
+  sig
+    type key
+    type 'a t
+    val create : ?seed:int -> 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
+    val stats: 'a t -> statistics
+  end
+
+module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
   struct
     type key = H.t
     type 'a hashtbl = (key, 'a) t
@@ -198,72 +263,73 @@ module Make(H: HashedType): (S with type key = H.t) =
     let clear = clear
     let copy = copy
 
-    let safehash key = (H.hash key) land max_int
+    let key_index h key =
+      (H.hash h.seed key) land (Array.length h.data - 1)
 
     let add h key info =
-      let i = (safehash key) mod (Array.length h.data) in
+      let i = key_index h key in
       let bucket = Cons(key, info, h.data.(i)) in
       h.data.(i) <- bucket;
-      h.size <- succ h.size;
-      if h.size > Array.length h.data lsl 1 then resize safehash h
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize key_index h
 
     let remove h key =
       let rec remove_bucket = function
-          Empty ->
+        | Empty ->
             Empty
         | Cons(k, i, next) ->
             if H.equal k key
-            then begin h.size <- pred h.size; next end
+            then begin h.size <- h.size - 1; next end
             else Cons(k, i, remove_bucket next) in
-      let i = (safehash key) mod (Array.length h.data) in
+      let i = key_index h key in
       h.data.(i) <- remove_bucket h.data.(i)
 
     let rec find_rec key = function
-        Empty ->
+      | Empty ->
           raise Not_found
       | Cons(k, d, rest) ->
           if H.equal key k then d else find_rec key rest
 
     let find h key =
-      match h.data.((safehash key) mod (Array.length h.data)) with
-        Empty -> raise Not_found
+      match h.data.(key_index h key) with
+      | Empty -> raise Not_found
       | Cons(k1, d1, rest1) ->
           if H.equal key k1 then d1 else
           match rest1 with
-            Empty -> raise Not_found
+          | Empty -> raise Not_found
           | Cons(k2, d2, rest2) ->
               if H.equal key k2 then d2 else
               match rest2 with
-                Empty -> raise Not_found
+              | Empty -> raise Not_found
               | Cons(k3, d3, rest3) ->
                   if H.equal key k3 then d3 else find_rec key rest3
 
     let find_all h key =
       let rec find_in_bucket = function
-        Empty ->
+      | Empty ->
           []
       | Cons(k, d, rest) ->
           if H.equal k key
           then d :: find_in_bucket rest
           else find_in_bucket rest in
-      find_in_bucket h.data.((safehash key) mod (Array.length h.data))
+      find_in_bucket h.data.(key_index h key)
 
     let replace h key info =
       let rec replace_bucket = function
-          Empty ->
+        | Empty ->
             raise Not_found
         | Cons(k, i, next) ->
             if H.equal k key
-            then Cons(k, info, next)
+            then Cons(key, info, next)
             else Cons(k, i, replace_bucket next) in
-      let i = (safehash key) mod (Array.length h.data) in
+      let i = key_index h key in
       let l = h.data.(i) in
       try
         h.data.(i) <- replace_bucket l
       with Not_found ->
         h.data.(i) <- Cons(key, info, l);
-        h.size <- succ h.size;
-        if h.size > Array.length h.data lsl 1 then resize safehash h
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize key_index h
 
     let mem h key =
       let rec mem_in_bucket = function
@@ -271,9 +337,20 @@ module Make(H: HashedType): (S with type key = H.t) =
           false
       | Cons(k, d, rest) ->
           H.equal k key || mem_in_bucket rest in
-      mem_in_bucket h.data.((safehash key) mod (Array.length h.data))
+      mem_in_bucket h.data.(key_index h key)
 
     let iter = iter
     let fold = fold
     let length = length
+    let stats = stats
+  end
+
+module Make(H: HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (seed: int) x = H.hash x
+      end)
+    let create sz = create ~seed:0 sz
   end
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index 1bf175ad..98d03198 100644
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -25,12 +25,22 @@
 type ('a, 'b) t
 (** The type of hash tables from type ['a] to type ['b]. *)
 
-val create : int -> ('a, 'b) t
+val create : ?seed:int -> int -> ('a, 'b) t
 (** [Hashtbl.create n] creates a new, empty hash table, with
    initial size [n].  For best results, [n] should be on the
    order of the expected number of elements that will be in
    the table.  The table grows as needed, so [n] is just an
-   initial guess. *)
+   initial guess.
+
+   The optional [seed] parameter (an integer) can be given to
+   diversify the hash function used to access the returned table.
+   With high probability, hash tables created with different seeds
+   have different collision patterns.  In Web-facing applications
+   for instance, it is recommended to create hash tables with a
+   randomly-chosen seed.  This prevents a denial-of-service attack
+   whereas a malicious user sends input crafted to create many
+   collisions in the table and therefore slow the application down.
+   @before 4.00.0 the [seed] parameter was not present. *)
 
 val clear : ('a, 'b) t -> unit
 (** Empty a hash table. *)
@@ -94,9 +104,29 @@ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
 
 val length : ('a, 'b) t -> int
 (** [Hashtbl.length tbl] returns the number of bindings in [tbl].
-   Multiple bindings are counted multiply, so [Hashtbl.length]
-   gives the number of times [Hashtbl.iter] calls its first argument. *)
-
+   It takes constant time.  Multiple bindings are counted once each, so
+   [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its
+   first argument. *)
+
+type statistics = {
+  num_bindings: int;
+    (** Number of bindings present in the table.
+        Same value as returned by {!Hashtbl.length}. *)
+  num_buckets: int;
+    (** Number of buckets in the table. *)
+  max_bucket_length: int;
+    (** Maximal number of bindings per bucket. *)
+  bucket_histogram: int array
+    (** Histogram of bucket sizes.  This array [histo] has
+        length [hash_max_bucket_length + 1].  The value of
+        [histo.(i)] is the number of buckets whose size is [i]. *)
+}
+
+val stats : ('a, 'b) t -> statistics
+(** [Hashtbl.stats tbl] returns statistics about the table [tbl]:
+   number of buckets, size of the biggest bucket, distribution of
+   buckets by size.
+   @since 4.00.0 *)
 
 (** {6 Functorial interface} *)
 
@@ -113,12 +143,13 @@ module type HashedType =
           as computed by [hash].
           Examples: suitable ([equal], [hash]) pairs for arbitrary key
           types include
-          ([(=)], {!Hashtbl.hash}) for comparing objects by structure,
-          ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
-          for comparing objects by structure and handling {!Pervasives.nan}
-          correctly, and
-          ([(==)], {!Hashtbl.hash}) for comparing objects by addresses
-          (e.g. for cyclic keys). *)
+-         ([(=)], {!Hashtbl.hash}) for comparing objects by structure
+              (provided objects do not contain floats)
+-         ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
+              for comparing objects by structure
+              and handling {!Pervasives.nan} correctly
+-         ([(==)], {!Hashtbl.hash}) for comparing objects by physical
+              equality (e.g. for mutable or cyclic objects). *)
    end
 (** The input signature of the functor {!Hashtbl.Make}. *)
 
@@ -138,6 +169,7 @@ module type S =
     val iter : (key -> 'a -> unit) -> 'a t -> unit
     val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val length : 'a t -> int
+    val stats: 'a t -> statistics
   end
 (** The output signature of the functor {!Hashtbl.Make}. *)
 
@@ -151,27 +183,88 @@ module Make (H : HashedType) : S with type key = H.t
     specified in the functor argument [H] instead of generic
     equality and hashing. *)
 
+module type SeededHashedType =
+  sig
+    type t
+      (** The type of the hashtable keys. *)
+    val equal: t -> t -> bool
+      (** The equality predicate used to compare keys. *)
+    val hash: int -> t -> int
+      (** A seeded hashing function on keys.  The first argument is
+          the seed.  It must be the case that if [equal x y] is true,
+          then [hash seed x = hash seed y] for any value of [seed].
+          A suitable choice for [hash] is the function {!Hashtbl.seeded_hash}
+          below. *)
+  end
+(** The input signature of the functor {!Hashtbl.MakeSeeded}.
+    @since 4.00.0 *)
+
+module type SeededS =
+  sig
+    type key
+    type 'a t
+    val create : ?seed:int -> 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
+    val stats: 'a t -> statistics
+  end
+(** The output signature of the functor {!Hashtbl.MakeSeeded}.
+    @since 4.00.0 *)
+
+module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
+(** Functor building an implementation of the hashtable structure.
+    The functor [Hashtbl.MakeSeeded] returns a structure containing
+    a type [key] of keys and a type ['a t] of hash tables
+    associating data of type ['a] to keys of type [key].
+    The operations perform similarly to those of the generic
+    interface, but use the seeded hashing and equality functions
+    specified in the functor argument [H] instead of generic
+    equality and hashing.
+    @since 4.00.0 *)
+
 
-(** {6 The polymorphic hash primitive} *)
+(** {6 The polymorphic hash functions} *)
 
 
 val hash : 'a -> int
-(** [Hashtbl.hash x] associates a positive integer to any value of
+(** [Hashtbl.hash x] associates a nonnegative integer to any value of
    any type. It is guaranteed that
    if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y].
-   Moreover, [hash] always terminates, even on cyclic
-   structures. *)
-
-external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
-(** [Hashtbl.hash_param n m x] computes a hash value for [x], with the
-   same properties as for [hash]. The two extra parameters [n] and
-   [m] give more precise control over hashing. Hashing performs a
-   depth-first, right-to-left traversal of the structure [x], stopping
-   after [n] meaningful nodes were encountered, or [m] nodes,
-   meaningful or not, were encountered. Meaningful nodes are: integers;
-   floating-point numbers; strings; characters; booleans; and constant
-   constructors. Larger values of [m] and [n] means that more
-   nodes are taken into account to compute the final hash
-   value, and therefore collisions are less likely to happen.
-   However, hashing takes longer. The parameters [m] and [n]
-   govern the tradeoff between accuracy and speed. *)
+   Moreover, [hash] always terminates, even on cyclic structures. *)
+
+val seeded_hash : int -> 'a -> int
+(** A variant of {!Hashtbl.hash} that is further parameterized by
+   an integer seed.
+   @since 4.00.0 *)
+
+val hash_param : int -> int -> 'a -> int
+(** [Hashtbl.hash_param meaningful total x] computes a hash value for [x],
+   with the same properties as for [hash]. The two extra integer
+   parameters [meaningful] and [total] give more precise control over
+   hashing. Hashing performs a breadth-first, left-to-right traversal
+   of the structure [x], stopping after [meaningful] meaningful nodes
+   were encountered, or [total] nodes (meaningful or not) were
+   encountered. Meaningful nodes are: integers; floating-point
+   numbers; strings; characters; booleans; and constant
+   constructors. Larger values of [meaningful] and [total] means that
+   more nodes are taken into account to compute the final hash value,
+   and therefore collisions are less likely to happen.  However,
+   hashing takes longer. The parameters [meaningful] and [total]
+   govern the tradeoff between accuracy and speed.  As default
+   choices, {!Hashtbl.hash} and {!Hashtbl.seeded_hash} take
+   [meaningful = 10] and [total = 100]. *)
+
+val seeded_hash_param : int -> int -> int -> 'a -> int
+(** A variant of {!Hashtbl.hash_param} that is further parameterized by
+   an integer seed.  Usage:
+   [Hashtbl.seeded_hash_param meaningful total seed x].
+   @since 4.00.0 *)
diff --git a/stdlib/header.c b/stdlib/header.c
index eda76325..c82c7bc7 100644
--- a/stdlib/header.c
+++ b/stdlib/header.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/stdlib/headernt.c b/stdlib/headernt.c
index c8d23ee2..9972d5d5 100644
--- a/stdlib/headernt.c
+++ b/stdlib/headernt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,7 +26,7 @@
 #pragma comment(lib , "kernel32")
 #endif
 
-char * default_runtime_name = "ocamlrun";
+char * default_runtime_name = RUNTIME_NAME;
 
 static
 #if _MSC_VER >= 1200
diff --git a/stdlib/int32.ml b/stdlib/int32.ml
index 64d525e8..15237d7f 100644
--- a/stdlib/int32.ml
+++ b/stdlib/int32.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/int32.mli b/stdlib/int32.mli
index eeafb1a2..8bc7384f 100644
--- a/stdlib/int32.mli
+++ b/stdlib/int32.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/int64.ml b/stdlib/int64.ml
index e916fa4e..d8b1c3ca 100644
--- a/stdlib/int64.ml
+++ b/stdlib/int64.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/int64.mli b/stdlib/int64.mli
index 3b641338..1f28f5c4 100644
--- a/stdlib/int64.mli
+++ b/stdlib/int64.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index b1a9cbbd..6a114245 100644
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -18,7 +18,7 @@
 
 (*
    WARNING: some purple magic is going on here.  Do not take this file
-   as an example of how to program in Objective Caml.
+   as an example of how to program in OCaml.
 *)
 
 
@@ -57,13 +57,13 @@ external force : 'a t -> 'a = "%lazy_force";;
 
 let force_val = CamlinternalLazy.force_val;;
 
-let lazy_from_fun (f : unit -> 'arg) =
+let from_fun (f : unit -> 'arg) =
   let x = Obj.new_block Obj.lazy_tag 1 in
   Obj.set_field x 0 (Obj.repr f);
   (Obj.obj x : 'arg t)
 ;;
 
-let lazy_from_val (v : 'arg) =
+let from_val (v : 'arg) =
   let t = Obj.tag (Obj.repr v) in
   if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin
     make_forward v
@@ -72,4 +72,10 @@ let lazy_from_val (v : 'arg) =
   end
 ;;
 
-let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
+let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
+
+let lazy_from_fun = from_fun;;
+
+let lazy_from_val = from_val;;
+
+let lazy_is_val = is_val;;
diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
index 3b85717f..9d720d2b 100644
--- a/stdlib/lazy.mli
+++ b/stdlib/lazy.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -42,8 +42,8 @@ type 'a t = 'a lazy_t;;
 
 exception Undefined;;
 
-external force : 'a t -> 'a = "%lazy_force";;
 (* val force : 'a t -> 'a ;; *)
+external force : 'a t -> 'a = "%lazy_force";;
 (** [force x] forces the suspension [x] and returns its result.
    If [x] has already been forced, [Lazy.force x] returns the
    same value again without recomputing it.  If it raised an exception,
@@ -62,15 +62,26 @@ val force_val : 'a t -> 'a;;
     whether [force_val x] raises the same exception or [Undefined].
 *)
 
+val from_fun : (unit -> 'a) -> 'a t;;
+(** [from_fun f] is the same as [lazy (f ())] but slightly more efficient.
+    @since 4.00.0 *)
+
+val from_val : 'a -> 'a t;;
+(** [from_val v] returns an already-forced suspension of [v].
+    This is for special purposes only and should not be confused with
+    [lazy (v)].
+    @since 4.00.0 *)
+
+val is_val : 'a t -> bool;;
+(** [is_val x] returns [true] if [x] has already been forced and
+    did not raise an exception.
+    @since 4.00.0 *)
+
 val lazy_from_fun : (unit -> 'a) -> 'a t;;
-(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more
-    efficient. *)
+(** @deprecated synonym for [from_fun]. *)
 
 val lazy_from_val : 'a -> 'a t;;
-(** [lazy_from_val v] returns an already-forced suspension of [v]
-    This is for special purposes only and should not be confused with
-    [lazy (v)]. *)
+(** @deprecated synonym for [from_val]. *)
 
 val lazy_is_val : 'a t -> bool;;
-(** [lazy_is_val x] returns [true] if [x] has already been forced and
-    did not raise an exception. *)
+(** @deprecated synonym for [is_val]. *)
diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
index 9e014152..4d03ec08 100644
--- a/stdlib/lexing.ml
+++ b/stdlib/lexing.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
index 2edb6c5d..a1a06901 100644
--- a/stdlib/lexing.mli
+++ b/stdlib/lexing.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,9 +26,12 @@ type position = {
 (** A value of type [position] describes a point in a source file.
    [pos_fname] is the file name; [pos_lnum] is the line number;
    [pos_bol] is the offset of the beginning of the line (number
-   of characters between the beginning of the file and the beginning
+   of characters between the beginning of the lexbuf and the beginning
    of the line); [pos_cnum] is the offset of the position (number of
-   characters between the beginning of the file and the position).
+   characters between the beginning of the lexbuf and the position).
+   The difference between [pos_cnum] and [pos_bol] is the character
+   offset within the line (i.e. the column number, assuming each
+   character is one column wide).
 
    See the documentation of type [lexbuf] for information about
    how the lexing engine will manage positions.
@@ -149,7 +152,7 @@ val flush_input : lexbuf -> unit
 (** {6  } *)
 
 (** The following definitions are used by the generated scanners only.
-   They are not intended to be used by user programs. *)
+   They are not intended to be used directly by user programs. *)
 
 val sub_lexeme : lexbuf -> int -> int -> string
 val sub_lexeme_opt : lexbuf -> int -> int -> string option
diff --git a/stdlib/list.ml b/stdlib/list.ml
index 8bb9e3fa..aea05b4b 100644
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -56,6 +56,12 @@ let rec map f = function
     [] -> []
   | 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 @@ let rec iter f = function
     [] -> ()
   | 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
diff --git a/stdlib/list.mli b/stdlib/list.mli
index 8f895619..855699d0 100644
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,11 +75,25 @@ val iter : ('a -> unit) -> 'a list -> unit
    [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 4.00.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 4.00.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
diff --git a/stdlib/listLabels.ml b/stdlib/listLabels.ml
index be7bddea..62b6e376 100644
--- a/stdlib/listLabels.ml
+++ b/stdlib/listLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
index 1f6a4ead..b4b58045 100644
--- a/stdlib/listLabels.mli
+++ b/stdlib/listLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,11 +75,25 @@ val iter : f:('a -> unit) -> 'a list -> unit
    [a1; ...; an]. It is equivalent to
    [begin f a1; f a2; ...; f an; () end]. *)
 
+val iteri : f:(int -> 'a -> unit) -> 'a list -> unit
+(** Same as {!List.iter}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
 val map : f:('a -> 'b) -> 'a list -> 'b list
 (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
    and builds the list [[f a1; ...; f an]]
    with the results returned by [f].  Not tail-recursive. *)
 
+val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list
+(** Same as {!List.map}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
 val rev_map : f:('a -> 'b) -> 'a list -> 'b list
 (** [List.rev_map f l] gives the same result as
    {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and
diff --git a/stdlib/map.ml b/stdlib/map.ml
index 3d9597aa..519ef824 100644
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -200,27 +200,31 @@ module Make(Ord: OrderedType) = struct
         Empty -> false
       | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
 
-    let filter p s =
-      let rec filt accu = function
-        | Empty -> accu
-        | Node(l, v, d, r, _) ->
-            filt (filt (if p v d then add v d accu else accu) l) r in
-      filt Empty s
+    (* Beware: those two functions assume that the added k is *strictly*
+       smaller (or bigger) than all the present keys in the tree; it
+       does not test for equality with the current min (or max) key.
 
-    let partition p s =
-      let rec part (t, f as accu) = function
-        | Empty -> accu
-        | Node(l, v, d, r, _) ->
-            part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in
-      part (Empty, Empty) s
+       Indeed, they are only used during the "join" operation which
+       respects this precondition.
+    *)
+
+    let rec add_min_binding k v = function
+      | Empty -> singleton k v
+      | Node (l, x, d, r, h) ->
+        bal (add_min_binding k v l) x d r
+
+    let rec add_max_binding k v = function
+      | Empty -> singleton k v
+      | Node (l, x, d, r, h) ->
+        bal l x d (add_max_binding k v r)
 
     (* Same as create and bal, but no assumptions are made on the
        relative heights of l and r. *)
 
     let rec join l v d r =
       match (l, r) with
-        (Empty, _) -> add v d r
-      | (_, Empty) -> add v d l
+        (Empty, _) -> add_min_binding v d r
+      | (_, Empty) -> add_max_binding v d l
       | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
           if lh > rh + 2 then bal ll lv ld (join lr v d r) else
           if rh > lh + 2 then bal (join l v d rl) rv rd rr else
@@ -266,6 +270,20 @@ module Make(Ord: OrderedType) = struct
       | _ ->
           assert false
 
+    let rec filter p = function
+        Empty -> Empty
+      | Node(l, v, d, r, _) ->
+          let l' = filter p l and r' = filter p r in
+          if p v d then join l' v d r' else concat l' r'
+
+    let rec partition p = function
+        Empty -> (Empty, Empty)
+      | Node(l, v, d, r, _) ->
+          let (lt, lf) = partition p l and (rt, rf) = partition p r in
+          if p v d
+          then (join lt v d rt, concat lf rf)
+          else (concat lt rt, join lf v d rf)
+
     type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
 
     let rec cons_enum m e =
diff --git a/stdlib/map.mli b/stdlib/map.mli
index b025b8c0..a6374dbd 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml
index 0410a23e..638f0543 100644
--- a/stdlib/marshal.ml
+++ b/stdlib/marshal.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -16,6 +16,7 @@
 type extern_flags =
     No_sharing
   | Closures
+(* note: this type definition is used in 'byterun/debugger.c' *)
 
 external to_channel: out_channel -> 'a -> extern_flags list -> unit
     = "caml_output_value"
diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index ac0775bb..86e1ebd1 100644
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,14 +20,14 @@
    sent over a pipe or network connection.  The bytes can then
    be read back later, possibly in another process, and decoded back
    into a data structure. The format for the byte sequences
-   is compatible across all machines for a given version of Objective Caml.
+   is compatible across all machines for a given version of OCaml.
 
    Warning: marshaling is currently not type-safe. The type
    of marshaled data is not transmitted along the value of the data,
    making it impossible to check that the data read back possesses the
    type expected by the context. In particular, the result type of
    the [Marshal.from_*] functions is given as ['a], but this is
-   misleading: the returned Caml value does not possess type ['a]
+   misleading: the returned OCaml value does not possess type ['a]
    for all ['a]; it has one, unique type which cannot be determined
    at compile-type.  The programmer should explicitly give the expected
    type of the returned value, using the following syntax:
@@ -115,7 +115,7 @@ val header_size : int
    {!Marshal.data_size}[ buff ofs] is the size, in characters,
    of the data part, assuming a valid header is stored in
    [buff] starting at position [ofs].
-   Finally, {!Marshal.total_size}[ buff ofs] is the total size,
+   Finally, {!Marshal.total_size} [buff ofs] is the total size,
    in characters, of the marshaled value.
    Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure]
    if [buff], [ofs] does not contain a valid header.
diff --git a/stdlib/moreLabels.ml b/stdlib/moreLabels.ml
index f6cfddab..3fda7a5b 100644
--- a/stdlib/moreLabels.ml
+++ b/stdlib/moreLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 55c77334..c2691cba 100644
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
@@ -19,13 +19,13 @@
    {!Map} and {!Set} modules.
 
    They only differ by their labels. They are provided to help
-   porting from previous versions of Objective Caml.
+   porting from previous versions of OCaml.
    The contents of this module are subject to change.
 *)
 
 module Hashtbl : sig
   type ('a, 'b) t = ('a, 'b) Hashtbl.t
-  val create : int -> ('a, 'b) t
+  val create : ?seed:int -> int -> ('a, 'b) t
   val clear : ('a, 'b) t -> unit
   val add : ('a, 'b) t -> key:'a -> data:'b -> unit
   val copy : ('a, 'b) t -> ('a, 'b) t
@@ -39,7 +39,10 @@ module Hashtbl : sig
       f:(key:'a -> data:'b -> 'c -> 'c) ->
         ('a, 'b) t -> init:'c -> 'c
   val length : ('a, 'b) t -> int
+  type statistics = Hashtbl.statistics
+  val stats : ('a, 'b) t -> statistics
   module type HashedType = Hashtbl.HashedType
+  module type SeededHashedType = Hashtbl.SeededHashedType
   module type S =
     sig
       type key
@@ -58,11 +61,34 @@ module Hashtbl : sig
           f:(key:key -> data:'a -> 'b -> 'b) ->
           'a t -> init:'b -> 'b
       val length : 'a t -> int
+      val stats: 'a t -> statistics
+    end
+  module type SeededS =
+    sig
+      type key
+      and 'a t
+      val create : ?seed:int -> int -> 'a t
+      val clear : 'a t -> unit
+      val copy : 'a t -> 'a t
+      val add : 'a t -> key:key -> data:'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:key -> data:'a -> unit
+      val mem : 'a t -> key -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+      val length : 'a t -> int
+      val stats: 'a t -> statistics
     end
   module Make : functor (H : HashedType) -> S with type key = H.t
+  module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
   val hash : 'a -> int
-  external hash_param : int -> int -> 'a -> int
-      = "caml_hash_univ_param" "noalloc"
+  val seeded_hash : int -> 'a -> int
+  val hash_param : int -> int -> 'a -> int
+  val seeded_hash_param : int -> int -> int -> 'a -> int
 end
 
 module Map : sig
diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
index 93478436..4bba76d5 100644
--- a/stdlib/nativeint.ml
+++ b/stdlib/nativeint.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
index ff499a26..7de11ea0 100644
--- a/stdlib/nativeint.mli
+++ b/stdlib/nativeint.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index c16b5115..96de162f 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 57df0491..9b66723b 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index c9ec64ae..40c8ae6e 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index b3111ce8..2a9eb232 100644
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -17,13 +17,22 @@
 
 val copy : (< .. > as 'a) -> 'a
 (** [Oo.copy o] returns a copy of object [o], that is a fresh
-   object with the same methods and instance variables as [o]  *)
+   object with the same methods and instance variables as [o]. *)
 
 external id : < .. > -> int = "%field1"
 (** Return an integer identifying this object, unique for
-    the current execution of the program. *)
+    the current execution of the program. The generic comparison
+    and hashing functions are based on this integer. When an object
+    is obtained by unmarshaling, the id is refreshed, and thus
+    different from the original object. As a consequence, the internal
+    invariants of data structures such as hash table or sets containing
+    objects are broken after unmarshaling the data structures.
+  *)
 
 (**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
 (** For internal use (CamlIDL) *)
 val new_method : string -> CamlinternalOO.tag
 val public_method_label : string -> CamlinternalOO.tag
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 5d53c741..55a8f53a 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 03721ba3..f4882459 100644
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -74,7 +74,7 @@ val set_trace: bool -> bool
 (** {6  } *)
 
 (** The following definitions are used by the generated parsers only.
-   They are not intended to be used by user programs. *)
+   They are not intended to be used directly by user programs. *)
 
 type parser_env
 
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 22dfa8fc..17a1a9c1 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,63 +26,63 @@ exception Exit
 
 (* 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 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"
@@ -90,6 +90,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 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"
@@ -103,6 +105,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 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"
@@ -131,16 +135,16 @@ type fpclass =
   | FP_zero
   | FP_infinite
   | FP_nan
-external classify_float: float -> fpclass = "caml_classify_float"
+external classify_float : float -> fpclass = "caml_classify_float"
 
 (* String operations -- more in module String *)
 
 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;
@@ -165,8 +169,8 @@ external snd : 'a * 'b -> 'b = "%field1"
 
 (* 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"
@@ -189,7 +193,7 @@ let valid_float_lexem s =
   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
@@ -201,7 +205,7 @@ external float_of_string : string -> float = "caml_float_of_string"
 
 (* List operations -- more in module List *)
 
-let rec (@) l1 l2 =
+let rec ( @ ) l1 l2 =
   match l1 with
     [] -> l2
   | hd :: tl -> hd :: (tl @ l2)
@@ -211,8 +215,9 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out"
-external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in"
+external open_descriptor_out : int -> out_channel
+                             = "caml_ml_open_descriptor_out"
+external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -225,7 +230,7 @@ type open_flag =
   | Open_creat | Open_trunc | Open_excl
   | Open_binary | Open_text | Open_nonblock
 
-external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
+external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
 
 let open_out_gen mode perm name =
   open_descriptor_out(open_desc name mode perm)
@@ -244,7 +249,7 @@ external out_channels_list : unit -> out_channel list
 let flush_all () =
   let rec iter = function
       [] -> ()
-    | a::l -> (try flush a with _ -> ()); iter l
+    | a :: l -> (try flush a with _ -> ()); iter l
   in iter (out_channels_list ())
 
 external unsafe_output : out_channel -> string -> int -> int -> unit
@@ -304,7 +309,7 @@ let rec unsafe_really_input ic s ofs len =
     let r = unsafe_input ic s ofs len in
     if r = 0
     then raise End_of_file
-    else unsafe_really_input ic s (ofs+r) (len-r)
+    else unsafe_really_input ic s (ofs + r) (len - r)
   end
 
 let really_input ic s ofs len =
@@ -328,8 +333,8 @@ let input_line chan =
         [] -> 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));
+      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
@@ -394,12 +399,12 @@ module LargeFile =
 
 (* 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
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index d741313d..bf19b2ae 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -52,24 +52,24 @@ external ( = ) : 'a -> 'a -> bool = "%equal"
    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 @@ external ( == ) : 'a -> 'a -> bool = "%eq"
    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 @@ external ( asr ) : int -> int -> int = "%asrint"
 
 (** {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
@@ -314,6 +314,14 @@ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
     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 4.00.0  *)
+
 external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 (** Hyperbolic cosine.  Argument is in radians. *)
 
@@ -337,6 +345,14 @@ external floor : float -> float = "caml_floor_float" "floor" "float"
 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 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
    [b].  The returned value is [a -. n *. b], where [n]
@@ -445,7 +461,9 @@ external ignore : 'a -> unit = "%ignore"
 (** {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.
@@ -642,7 +660,7 @@ val output_binary_int : out_channel -> int -> unit
    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,16 +873,16 @@ external decr : int ref -> unit = "%decr"
 (** Format strings have a general and highly polymorphic type
     [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
     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,
     ['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.
+    ['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.
  *)
 type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 
@@ -893,7 +911,7 @@ val exit : int -> 'a
 (** 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. *)
@@ -908,8 +926,7 @@ val at_exit : (unit -> unit) -> unit
 
 (**/**)
 
-
-(** {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
 
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 9e435c59..062decb8 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -56,6 +56,8 @@ let to_string x =
             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
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index 71a6af55..93ee5d6d 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -77,5 +77,10 @@ val register_printer: (exn -> string option) -> unit
     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
 *)
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index 13f16dd6..c55c64d3 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -217,7 +217,7 @@ let iter_on_format_args fmt add_conv add_char =
   and scan_conv skip i =
     if i > lim then incomplete_format fmt else
     match Sformat.unsafe_get fmt i with
-    | '%' | '!' | ',' -> succ i
+    | '%' | '@' | '!' | ',' -> succ i
     | 's' | 'S' | '[' -> add_conv skip i 's'
     | 'c' | 'C' -> add_conv skip i 'c'
     | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i'
@@ -230,7 +230,7 @@ let iter_on_format_args fmt add_conv add_char =
         match Sformat.get fmt j with
         | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
           add_char (add_conv skip i conv) 'i'
-        | c -> add_conv skip i 'i' end
+        | _ -> add_conv skip i 'i' end
     | '{' as conv ->
       (* Just get a regular argument, skipping the specification. *)
       let i = add_conv skip i conv in
@@ -301,7 +301,7 @@ let ac_of_format fmt =
     (* Just finishing a meta format: no additional argument to record. *)
     if c <> ')' && c <> '}' then incr_ac skip c;
     succ i
-  and add_char i c = succ i in
+  and add_char i _ = succ i in
 
   iter_on_format_args fmt add_conv add_char;
   ac
@@ -391,9 +391,9 @@ type positional_specification =
    with $n$ being the {\em value} of the integer argument defining [*]; we
    clearly cannot statically guess the value of this parameter in the general
    case. Put it another way: this means type dependency, which is completely
-   out of scope of the Caml type algebra. *)
+   out of scope of the OCaml type algebra. *)
 
-let scan_positional_spec fmt got_spec n i =
+let scan_positional_spec fmt got_spec i =
   match Sformat.unsafe_get fmt i with
   | '0'..'9' as d ->
     let rec get_int_literal accu j =
@@ -430,7 +430,7 @@ let get_index spec n =
   | Spec_index p -> p
 ;;
 
-(* Format a float argument as a valid Caml lexeme. *)
+(* Format a float argument as a valid OCaml lexeme. *)
 let format_float_lexeme =
 
   (* To be revised: this procedure should be a unique loop that performs the
@@ -443,7 +443,7 @@ let format_float_lexeme =
   let make_valid_float_lexeme s =
     (* Check if s is already a valid lexeme:
        in this case do nothing,
-       otherwise turn s into a valid Caml lexeme. *)
+       otherwise turn s into a valid OCaml lexeme. *)
     let l = String.length s in
     let rec valid_float_loop i =
       if i >= l then s ^ "." else
@@ -490,7 +490,7 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
 
   let rec scan_positional n widths i =
     let got_spec spec i = scan_flags spec n widths i in
-    scan_positional_spec fmt got_spec n i
+    scan_positional_spec fmt got_spec i
 
   and scan_flags spec n widths i =
     match Sformat.unsafe_get fmt i with
@@ -498,15 +498,17 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
       let got_spec wspec i =
         let (width : int) = get_arg wspec n in
         scan_flags spec (next_index wspec n) (width :: widths) i in
-      scan_positional_spec fmt got_spec n (succ i)
+      scan_positional_spec fmt got_spec (succ i)
     | '0'..'9'
     | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i)
     | _ -> scan_conv spec n widths i
 
   and scan_conv spec n widths i =
     match Sformat.unsafe_get fmt i with
-    | '%' ->
-      cont_s n "%" (succ i)
+    | '%' | '@' as c ->
+      cont_s n (String.make 1 c) (succ i)
+    | '!' -> cont_f n (succ i)
+    | ',' -> cont_s n "" (succ i)
     | 's' | 'S' as conv ->
       let (x : string) = get_arg spec n in
       let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in
@@ -515,6 +517,8 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
         if i = succ pos then x else
         format_string (extract_format fmt pos i widths) x in
       cont_s (next_index spec n) s (succ i)
+    | '[' as conv ->
+      bad_conversion_format fmt i conv
     | 'c' | 'C' as conv ->
       let (x : char) = get_arg spec n in
       let s =
@@ -546,6 +550,8 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
       let n = Sformat.succ_index (get_index spec n) in
       let arg = get_arg Spec_none n in
       cont_a (next_index spec n) printer arg (succ i)
+    | 'r' as conv ->
+      bad_conversion_format fmt i conv
     | 't' ->
       let printer = get_arg spec n in
       cont_t (next_index spec n) printer (succ i)
@@ -570,8 +576,6 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
         let s = format_int (extract_format_int 'n' fmt pos i widths) x in
         cont_s (next_index spec n) s (succ i)
       end
-    | ',' -> cont_s n "" (succ i)
-    | '!' -> cont_f n (succ i)
     | '{' | '(' as conv (* ')' '}' *) ->
       let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
       let i = succ i in
@@ -637,7 +641,7 @@ let mkprintf to_s get_out outc outs flush k fmt =
 let kfprintf k oc =
   mkprintf false (fun _ -> oc) output_char output_string flush k
 ;;
-let ifprintf oc = kapr (fun _ -> Obj.magic ignore);;
+let ifprintf _ = kapr (fun _ -> Obj.magic ignore);;
 
 let fprintf oc = kfprintf ignore oc;;
 let printf fmt = fprintf stdout fmt;;
@@ -670,7 +674,7 @@ let sprintf fmt = ksprintf (fun s -> s) fmt;;
 (* Obsolete and deprecated. *)
 let kprintf = ksprintf;;
 
-(* For Caml system internal use only: needed to implement modules [Format]
+(* For OCaml system internal use only: needed to implement modules [Format]
   and [Scanf]. *)
 
 module CamlinternalPr = struct
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index e122dece..6fcb45eb 100644
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -20,71 +20,77 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    [arg1] to [argN] according to the format string [format], and
    outputs the resulting string on the channel [outchan].
 
-   The format is a character string which contains two types of
+   The format string is a character string which contains two types of
    objects: plain characters, which are simply copied to the output
    channel, and conversion specifications, each of which causes
    conversion and printing of arguments.
 
    Conversion specifications have the following form:
 
-   [% \[flags\] \[width\] \[.precision\] type]
+   [% [flags] [width] [.precision] type]
 
    In short, a conversion specification consists in the [%] character,
    followed by optional modifiers and a type which is made of one or
-   two characters. The types and their meanings are:
+   two characters.
 
-   - [d], [i], [n], [l], [L], or [N]: convert an integer argument to
-     signed decimal.
-   - [u]: convert an integer argument to unsigned decimal.
+   The types and their meanings are:
+
+   - [d], [i]: convert an integer argument to signed decimal.
+   - [u], [n], [l], [L], or [N]: convert an integer argument to
+     unsigned decimal.  Warning: [n], [l], [L], and [N] are
+     used for [scanf], and should not be used for [printf].
    - [x]: convert an integer argument to unsigned hexadecimal,
      using lowercase letters.
    - [X]: convert an integer argument to unsigned hexadecimal,
      using uppercase letters.
    - [o]: convert an integer argument to unsigned octal.
    - [s]: insert a string argument.
-   - [S]: insert a string argument in Caml syntax (double quotes, escapes).
+   - [S]: convert a string argument to OCaml syntax (double quotes, escapes).
    - [c]: insert a character argument.
-   - [C]: insert a character argument in Caml 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 Caml syntax ([dddd.]
+   - [F]: convert a floating-point argument to OCaml syntax ([dddd.]
      or [dddd.ddd] or [d.ddd e+-dd]).
    - [e] or [E]: convert a floating-point argument to decimal notation,
      in the style [d.ddd e+-dd] (mantissa and exponent).
    - [g] or [G]: convert a floating-point argument to decimal notation,
      in style [f] or [e], [E] (whichever is more compact).
    - [B]: convert a boolean argument to the string [true] or [false]
-   - [b]: convert a boolean argument (for backward compatibility; do not
-     use in new programs).
+   - [b]: convert a boolean argument (deprecated; do not use in new
+     programs).
    - [ld], [li], [lu], [lx], [lX], [lo]: convert an [int32] argument to
      the format specified by the second letter (decimal, hexadecimal, etc).
    - [nd], [ni], [nu], [nx], [nX], [no]: convert a [nativeint] argument to
      the format specified by the second letter.
    - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to
      the format specified by the second letter.
-   - [a]: user-defined printer. Takes two arguments and applies the
+   - [a]: user-defined printer. Take two arguments and apply the
      first one to [outchan] (the current output channel) and to the
      second argument. The first argument must therefore have type
      [out_channel -> 'b -> unit] and the second ['b].
      The output produced by the function is inserted in the output of
      [fprintf] at the current point.
-   - [t]: same as [%a], but takes only one argument (with type
+   - [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 %)]: format string substitution. Takes a format string
-     argument and substitutes it to 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
      type as the internal format string [fmt].
    - [!]: take no argument and flush the output.
    - [%]: take no argument and output one [%] character.
-   - [,]: the no-op delimiter for conversion specifications.
+   - [\@]: take no argument and output one [\@] character.
+   - [,]: take no argument and do nothing.
 
    The optional [flags] are:
    - [-]: left-justify the output (default is right justification).
    - [0]: for numerical conversions, pad with zeroes instead of spaces.
-   - [+]: for numerical conversions, prefix number with a [+] sign if positive.
-   - space: for numerical conversions, prefix number with a space if positive.
+   - [+]: for signed numerical conversions, prefix number with a [+]
+     sign if positive.
+   - space: for signed numerical conversions, prefix number with a
+     space if positive.
    - [#]: request an alternate formatting style for numbers.
 
    The optional [width] is an integer indicating the minimal
@@ -153,7 +159,7 @@ val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
 
 (**/**)
 
-(* For Caml system internal use only. Don't call directly. *)
+(* The following is for system use only. Do not call directly. *)
 
 module CamlinternalPr : sig
 
diff --git a/stdlib/queue.ml b/stdlib/queue.ml
index 9e21686a..388a46c5 100644
--- a/stdlib/queue.ml
+++ b/stdlib/queue.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        François Pottier, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -15,7 +15,7 @@
 
 exception Empty
 
-(* O'Caml currently does not allow the components of a sum type to be
+(* OCaml currently does not allow the components of a sum type to be
    mutable. Yet, for optimal space efficiency, we must have cons cells
    whose [next] field is mutable. This leads us to define a type of
    cyclic lists, so as to eliminate the [Nil] case and the sum
@@ -54,12 +54,12 @@ let clear q =
   q.tail <- Obj.magic None
 
 let add x q =
-  q.length <- q.length + 1;
-  if q.length = 1 then
+  if q.length = 0 then
     let rec cell = {
       content = x;
       next = cell
     } in
+    q.length <- 1;
     q.tail <- cell
   else
     let tail = q.tail in
@@ -68,6 +68,7 @@ let add x q =
       content = x;
       next = head
     } in
+    q.length <- q.length + 1;
     tail.next <- cell;
     q.tail <- cell
 
diff --git a/stdlib/queue.mli b/stdlib/queue.mli
index 085cfb00..5dea9244 100644
--- a/stdlib/queue.mli
+++ b/stdlib/queue.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/random.ml b/stdlib/random.ml
index bd397991..800c6297 100644
--- a/stdlib/random.ml
+++ b/stdlib/random.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Damien Doligez, projet Para, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -25,7 +25,7 @@
    passes all the Diehard tests.
 *)
 
-external random_seed: unit -> int = "caml_sys_random_seed";;
+external random_seed: unit -> int array = "caml_sys_random_seed";;
 
 module State = struct
 
@@ -43,7 +43,7 @@ module State = struct
       Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16)
       + (Char.code d.[3] lsl 24)
     in
-    let seed = if seed = [| |] then [| 0 |] else seed in
+    let seed = if Array.length seed = 0 then [| 0 |] else seed in
     let l = Array.length seed in
     for i = 0 to 54 do
       s.st.(i) <- i;
@@ -53,7 +53,7 @@ module State = struct
       let j = i mod 55 in
       let k = i mod l in
       accu := combine !accu seed.(k);
-      s.st.(j) <- s.st.(j) lxor extract !accu;
+      s.st.(j) <- (s.st.(j) lxor extract !accu) land 0x3FFFFFFF;  (* PR#5575 *)
     done;
     s.idx <- 0;
   ;;
@@ -64,7 +64,7 @@ module State = struct
     result
   ;;
 
-  let make_self_init () = make [| random_seed () |];;
+  let make_self_init () = make (random_seed ());;
 
   let copy s =
     let result = new_state () in
@@ -75,10 +75,12 @@ module State = struct
   (* Returns 30 random bits as an integer 0 <= x < 1073741824 *)
   let bits s =
     s.idx <- (s.idx + 1) mod 55;
+    let curval = s.st.(s.idx) in
     let newval = s.st.((s.idx + 24) mod 55)
-                 + (s.st.(s.idx) lxor ((s.st.(s.idx) lsr 25) land 31)) in
-    s.st.(s.idx) <- newval;
-    newval land 0x3FFFFFFF   (* land is needed for 64-bit arch *)
+                 + (curval lxor ((curval lsr 25) land 0x1F)) in
+    let newval30 = newval land 0x3FFFFFFF in  (* PR#5575 *)
+    s.st.(s.idx) <- newval30;
+    newval30
   ;;
 
   let rec intaux s n =
@@ -129,13 +131,12 @@ module State = struct
     else fun s bound -> Int64.to_nativeint (int64 s (Int64.of_nativeint bound))
   ;;
 
-  (* Returns a float 0 <= x < 1 with at most 90 bits of precision. *)
+  (* Returns a float 0 <= x <= 1 with at most 60 bits of precision. *)
   let rawfloat s =
-    let scale = 1073741824.0
-    and r0 = Pervasives.float (bits s)
+    let scale = 1073741824.0  (* 2^30 *)
     and r1 = Pervasives.float (bits s)
     and r2 = Pervasives.float (bits s)
-    in ((r0 /. scale +. r1) /. scale +. r2) /. scale
+    in (r1 /. scale +. r2) /. scale
   ;;
 
   let float s bound = rawfloat s *. bound;;
@@ -171,7 +172,7 @@ let bool () = State.bool default;;
 
 let full_init seed = State.full_init default seed;;
 let init seed = State.full_init default [| seed |];;
-let self_init () = init (random_seed());;
+let self_init () = full_init (random_seed());;
 
 (* Manipulating the current state. *)
 
diff --git a/stdlib/random.mli b/stdlib/random.mli
index 88387d19..d8ea01e6 100644
--- a/stdlib/random.mli
+++ b/stdlib/random.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Damien Doligez, projet Para, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -25,8 +25,11 @@ val full_init : int array -> unit
 (** Same as {!Random.init} but takes more data as seed. *)
 
 val self_init : unit -> unit
-(** Initialize the generator with a more-or-less random seed chosen
-   in a system-dependent way. *)
+(** Initialize the generator with a random seed chosen
+   in a system-dependent way.  If [/dev/urandom] is available on
+   the host machine, it is used to provide a highly random initial
+   seed.  Otherwise, a less random seed is computed from system
+   parameters (current time, process IDs). *)
 
 val bits : unit -> int
 (** Return 30 random bits in a nonnegative integer.
@@ -53,7 +56,7 @@ val int64 : Int64.t -> Int64.t;;
 
 val float : float -> float
 (** [Random.float bound] returns a random floating-point number
-   between 0 (inclusive) and [bound] (exclusive).  If [bound] is
+   between 0 and [bound] (inclusive).  If [bound] is
    negative, the result is negative or zero.  If [bound] is 0,
    the result is 0. *)
 
@@ -64,7 +67,7 @@ val bool : unit -> bool
 (** {6 Advanced functions} *)
 
 (** The functions from module [State] manipulate the current state
-    of the random generator explicitely.
+    of the random generator explicitly.
     This allows using one or several deterministic PRNGs,
     even in a multi-threaded program, without interference from
     other parts of the program.
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 3d3d16c2..cac4a136 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -22,6 +22,8 @@ module type SCANNING = sig
 
   type scanbuf = in_channel;;
 
+  type file_name = string;;
+
   val stdin : in_channel;;
   (* The scanning buffer reading from [Pervasives.stdin].
       [stdib] is equivalent to [Scanning.from_channel Pervasives.stdin]. *)
@@ -104,15 +106,15 @@ module type SCANNING = sig
   (* [Scanning.name_of_input ib] returns the name of the character
       source for input buffer [ib]. *)
 
-  val open_in : string -> scanbuf;;
-  val open_in_bin : string -> scanbuf;;
-  val from_file : string -> scanbuf;;
-  val from_file_bin : string -> scanbuf;;
-  val from_string : string -> scanbuf;;
-  val from_function : (unit -> char) -> scanbuf;;
-  val from_channel : Pervasives.in_channel -> scanbuf;;
+  val open_in : file_name -> in_channel;;
+  val open_in_bin : file_name -> in_channel;;
+  val from_file : file_name -> in_channel;;
+  val from_file_bin : file_name -> in_channel;;
+  val from_string : string -> in_channel;;
+  val from_function : (unit -> char) -> in_channel;;
+  val from_channel : Pervasives.in_channel -> in_channel;;
 
-  val close_in : scanbuf -> unit;;
+  val close_in : in_channel -> unit;;
 
 end
 ;;
@@ -142,6 +144,8 @@ module Scanning : SCANNING = struct
 
   type scanbuf = in_channel;;
 
+  type file_name = string;;
+
   let null_char = '\000';;
 
   (* Reads a new character from input buffer.  Next_char never fails,
@@ -210,16 +214,16 @@ module Scanning : SCANNING = struct
 
   let token_count ib = ib.token_count;;
 
-  let skip_char max ib =
+  let skip_char width ib =
     invalidate_current_char ib;
-    max
+    width
   ;;
 
-  let ignore_char max ib = skip_char (max - 1) ib;;
+  let ignore_char width ib = skip_char (width - 1) ib;;
 
-  let store_char max ib c =
+  let store_char width ib c =
     Buffer.add_char ib.tokbuf c;
-    ignore_char max ib
+    ignore_char width ib
   ;;
 
   let default_token_buffer_size = 1024;;
@@ -428,19 +432,14 @@ let bad_end_of_input message =
         premature end of file occurred before end of token" message)
 ;;
 
-let int_max = function
+let int_of_width_opt = function
   | None -> max_int
-  | Some max -> max
-;;
-
-let int_min = function
-  | None -> 0
-  | Some max -> max
+  | Some width -> width
 ;;
 
-let float_min = function
+let int_of_prec_opt = function
   | None -> max_int
-  | Some min -> min
+  | Some prec -> prec
 ;;
 
 module Sformat = Printf.CamlinternalPr.Sformat;;
@@ -484,7 +483,7 @@ 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 explicitely 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
@@ -589,55 +588,55 @@ let token_int64 conv ib = int64_of_string (token_int_literal conv ib);;
    available before calling one of the digit scanning functions). *)
 
 (* The decimal case is treated especially for optimization purposes. *)
-let rec scan_decimal_digits max ib =
-  if max = 0 then max else
+let rec scan_decimal_digits width ib =
+  if width = 0 then width else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max else
+  if Scanning.eof ib then width else
   match c with
   | '0' .. '9' as c ->
-    let max = Scanning.store_char max ib c in
-    scan_decimal_digits max ib
+    let width = Scanning.store_char width ib c in
+    scan_decimal_digits width ib
   | '_' ->
-    let max = Scanning.ignore_char max ib in
-    scan_decimal_digits max ib
-  | _ -> max
+    let width = Scanning.ignore_char width ib in
+    scan_decimal_digits width ib
+  | _ -> width
 ;;
 
-let scan_decimal_digits_plus max ib =
-  if max = 0 then bad_token_length "decimal digits" else
+let scan_decimal_digits_plus width ib =
+  if width = 0 then bad_token_length "decimal digits" else
   let c = Scanning.checked_peek_char ib in
   match c with
   | '0' .. '9' ->
-    let max = Scanning.store_char max ib c in
-    scan_decimal_digits max ib
+    let width = Scanning.store_char width ib c in
+    scan_decimal_digits width ib
   | c ->
     bad_input (Printf.sprintf "character %C is not a decimal digit" c)
 ;;
 
-let scan_digits_plus digitp max ib =
+let scan_digits_plus digitp width ib =
   (* To scan numbers from other bases, we use a predicate argument to
      scan_digits. *)
-  let rec scan_digits max =
-    if max = 0 then max else
+  let rec scan_digits width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     match c with
     | c when digitp c ->
-      let max = Scanning.store_char max ib c in
-      scan_digits max
+      let width = Scanning.store_char width ib c in
+      scan_digits width
     | '_' ->
-      let max = Scanning.ignore_char max ib in
-      scan_digits max
-    | _ -> max in
+      let width = Scanning.ignore_char width ib in
+      scan_digits width
+    | _ -> width in
 
   (* Ensure we have got enough width left,
      and read at list one digit. *)
-  if max = 0 then bad_token_length "digits" else
+  if width = 0 then bad_token_length "digits" else
   let c = Scanning.checked_peek_char ib in
 
   if digitp c then
-    let max = Scanning.store_char max ib c in
-    scan_digits max
+    let width = Scanning.store_char width ib c in
+    scan_digits width
   else
     bad_input (Printf.sprintf "character %C is not a digit" c)
 ;;
@@ -666,145 +665,147 @@ let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
 (* Scan a decimal integer. *)
 let scan_unsigned_decimal_int = scan_decimal_digits_plus;;
 
-let scan_sign max ib =
+let scan_sign width ib =
   let c = Scanning.checked_peek_char ib in
   match c with
-  | '+' -> Scanning.store_char max ib c
-  | '-' -> Scanning.store_char max ib c
-  | c -> max
+  | '+' -> Scanning.store_char width ib c
+  | '-' -> Scanning.store_char width ib c
+  | _ -> width
 ;;
 
-let scan_optionally_signed_decimal_int max ib =
-  let max = scan_sign max ib in
-  scan_unsigned_decimal_int max ib
+let scan_optionally_signed_decimal_int width ib =
+  let width = scan_sign width ib in
+  scan_unsigned_decimal_int width ib
 ;;
 
 (* Scan an unsigned integer that could be given in any (common) basis.
    If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is
    assumed to be written respectively in hexadecimal, hexadecimal,
    octal, or binary. *)
-let scan_unsigned_int max ib =
+let scan_unsigned_int width ib =
   match Scanning.checked_peek_char ib with
   | '0' as c ->
-    let max = Scanning.store_char max ib c in
-    if max = 0 then max else
+    let width = Scanning.store_char width ib c in
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     begin match c with
-    | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char max ib c) ib
-    | 'o' -> scan_octal_int (Scanning.store_char max ib c) ib
-    | 'b' -> scan_binary_int (Scanning.store_char max ib c) ib
-    | c -> scan_decimal_digits max ib end
-  | c -> scan_unsigned_decimal_int max ib
+    | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char width ib c) ib
+    | 'o' -> scan_octal_int (Scanning.store_char width ib c) ib
+    | 'b' -> scan_binary_int (Scanning.store_char width ib c) ib
+    | _ -> scan_decimal_digits width ib end
+  | _ -> scan_unsigned_decimal_int width ib
 ;;
 
-let scan_optionally_signed_int max ib =
-  let max = scan_sign max ib in
-  scan_unsigned_int max ib
+let scan_optionally_signed_int width ib =
+  let width = scan_sign width ib in
+  scan_unsigned_int width ib
 ;;
 
-let scan_int_conv conv max _min ib =
+let scan_int_conv conv width _prec ib =
   match conv with
-  | 'b' -> scan_binary_int max ib
-  | 'd' -> scan_optionally_signed_decimal_int max ib
-  | 'i' -> scan_optionally_signed_int max ib
-  | 'o' -> scan_octal_int max ib
-  | 'u' -> scan_unsigned_decimal_int max ib
-  | 'x' | 'X' -> scan_hexadecimal_int max ib
-  | c -> assert false
+  | 'b' -> scan_binary_int width ib
+  | 'd' -> scan_optionally_signed_decimal_int width ib
+  | 'i' -> scan_optionally_signed_int width ib
+  | 'o' -> scan_octal_int width ib
+  | 'u' -> scan_unsigned_decimal_int width ib
+  | 'x' | 'X' -> scan_hexadecimal_int width ib
+  | _ -> assert false
 ;;
 
 (* Scanning floating point numbers. *)
 (* Fractional part is optional and can be reduced to 0 digits. *)
-let scan_frac_part max ib =
-  if max = 0 then max else
+let scan_frac_part width ib =
+  if width = 0 then width else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max else
+  if Scanning.eof ib then width else
   match c with
   | '0' .. '9' as c ->
-    scan_decimal_digits (Scanning.store_char max ib c) ib
-  | _ -> max
+    scan_decimal_digits (Scanning.store_char width ib c) ib
+  | _ -> width
 ;;
 
 (* Exp part is optional and can be reduced to 0 digits. *)
-let scan_exp_part max ib =
-  if max = 0 then max else
+let scan_exp_part width ib =
+  if width = 0 then width else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max else
+  if Scanning.eof ib then width else
   match c with
   | 'e' | 'E' as c ->
-    scan_optionally_signed_decimal_int (Scanning.store_char max ib c) ib
-  | _ -> max
+    scan_optionally_signed_decimal_int (Scanning.store_char width ib c) ib
+  | _ -> width
 ;;
 
 (* Scan the integer part of a floating point number, (not using the
-   Caml lexical convention since the integer part can be empty):
+   OCaml lexical convention since the integer part can be empty):
    an optional sign, followed by a possibly empty sequence of decimal
    digits (e.g. -.1). *)
-let scan_int_part max ib =
-  let max = scan_sign max ib in
-  scan_decimal_digits max ib
+let scan_int_part width ib =
+  let width = scan_sign width ib in
+  scan_decimal_digits width ib
 ;;
 
 (*
-    For the time being we have (as found in scanf.mli):
-    The field width is composed of an optional integer literal
-    indicating the maximal width of the token to read.
-    Unfortunately, the type-checker let the user write an optional precision,
-    since this is valid for printf format strings.
+   For the time being we have (as found in scanf.mli):
+   The field width is composed of an optional integer literal
+   indicating the maximal width of the token to read.
+   Unfortunately, the type-checker let the user write an optional precision,
+   since this is valid for printf format strings.
 
-   Thus, the next step for Scanf is to support a full width indication, more
-   or less similar to the one for printf, possibly extended to the
-   specification of a [max, min] range for the width of the token read for
-   strings. Something like the following spec for scanf.mli:
+   Thus, the next step for Scanf is to support a full width and precision
+   indication, more or less similar to the one for printf, possibly extended
+   to the specification of a [max, min] range for the width of the token read
+   for strings. Something like the following spec for scanf.mli:
 
    The optional [width] is an integer indicating the maximal
    width of the token read. For instance, [%6d] reads an integer,
    having at most 6 characters.
 
    The optional [precision] is a dot [.] followed by an integer:
-   - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E], and
-   [%F] conversions, the [precision] indicates the maximum number of digits
-   that may follow the decimal point. For instance, [%.4f] reads a [float]
-   with at most 4 fractional digits,
+
+   - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E],
+   and [%F] conversions, the [precision] indicates the maximum number of
+   digits that may follow the decimal point. For instance, [%.4f] reads a
+   [float] with at most 4 fractional digits,
+
    - in the string conversions ([%s], [%S], [%\[ range \]]), and in the
    integer number conversions ([%i], [%d], [%u], [%x], [%o], and their
-   [int32], [int64], and [native_int] correspondent), the
-   [precision] indicates the required minimum width of the token read,
+   [int32], [int64], and [native_int] correspondent), the [precision]
+   indicates the required minimum width of the token read,
+
    - on all other conversions, the width and precision are meaningless and
    ignored (FIXME: lead to a runtime error ? type checking error ?).
-
 *)
-let scan_float max max_frac_part ib =
-  let max = scan_int_part max ib in
-  if max = 0 then max, max_frac_part else
+
+let scan_float width precision ib =
+  let width = scan_int_part width ib in
+  if width = 0 then width, precision else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max, max_frac_part else
+  if Scanning.eof ib then width, precision else
   match c with
   | '.' ->
-    let max = Scanning.store_char max ib c in
-    let max_precision = min max max_frac_part in
-    let max = max - (max_precision - scan_frac_part max_precision ib) in
-    scan_exp_part max ib, max_frac_part
-  | c ->
-    scan_exp_part max ib, max_frac_part
+    let width = Scanning.store_char width ib c in
+    let precision = min width precision in
+    let width = width - (precision - scan_frac_part precision ib) in
+    scan_exp_part width ib, precision
+  | _ ->
+    scan_exp_part width ib, precision
 ;;
 
-let scan_Float max max_frac_part ib =
-  let max = scan_optionally_signed_decimal_int max ib in
-  if max = 0 then bad_float () else
+let scan_Float width precision ib =
+  let width = scan_optionally_signed_decimal_int width ib in
+  if width = 0 then bad_float () else
   let c = Scanning.peek_char ib in
   if Scanning.eof ib then bad_float () else
   match c with
   | '.' ->
-    let max = Scanning.store_char max ib c in
-    let max_precision = min max max_frac_part in
-    let max = max - (max_precision - scan_frac_part max_precision ib) in
-    let max = scan_frac_part max ib in
-    scan_exp_part max ib
+    let width = Scanning.store_char width ib c in
+    let precision = min width precision in
+    let width = width - (precision - scan_frac_part precision ib) in
+    scan_exp_part width ib
   | 'e' | 'E' ->
-    scan_exp_part max ib
-  | c -> bad_float ()
+    scan_exp_part width ib
+  | _ -> bad_float ()
 ;;
 
 (* Scan a regular string:
@@ -813,26 +814,26 @@ let scan_Float max max_frac_part ib =
    indication list [stp].
    It also stops at end of file or when the maximum number of characters has
    been read.*)
-let scan_string stp max ib =
-  let rec loop max =
-    if max = 0 then max else
+let scan_string stp width ib =
+  let rec loop width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if stp = [] then
       match c with
-      | ' ' | '\t' | '\n' | '\r' -> max
-      | c -> loop (Scanning.store_char max ib c) else
-    if List.memq c stp then Scanning.skip_char max ib else
-    loop (Scanning.store_char max ib c) in
-  loop max
+      | ' ' | '\t' | '\n' | '\r' -> width
+      | c -> loop (Scanning.store_char width ib c) else
+    if List.memq c stp then Scanning.skip_char width ib else
+    loop (Scanning.store_char width ib c) in
+  loop width
 ;;
 
 (* Scan a char: peek strictly one character in the input, whatsoever. *)
-let scan_char max ib =
-  (* The case max = 0 could not happen here, since it is tested before
+let scan_char width ib =
+  (* The case width = 0 could not happen here, since it is tested before
      calling scan_char, in the main scanning function.
-    if max = 0 then bad_token_length "a character" else *)
-  Scanning.store_char max ib (Scanning.checked_peek_char ib)
+    if width = 0 then bad_token_length "a character" else *)
+  Scanning.store_char width ib (Scanning.checked_peek_char ib)
 ;;
 
 let char_for_backslash = function
@@ -887,8 +888,8 @@ let char_for_hexadecimal_code c1 c2 =
 
 (* Called in particular when encountering '\\' as starter of a char.
    Stops before the corresponding '\''. *)
-let check_next_char message max ib =
-  if max = 0 then bad_token_length message else
+let check_next_char message width ib =
+  if width = 0 then bad_token_length message else
   let c = Scanning.peek_char ib in
   if Scanning.eof ib then bad_end_of_input message else
   c
@@ -897,10 +898,10 @@ let check_next_char message max ib =
 let check_next_char_for_char = check_next_char "a Char";;
 let check_next_char_for_string = check_next_char "a String";;
 
-let scan_backslash_char max ib =
-  match check_next_char_for_char max ib with
+let scan_backslash_char width ib =
+  match check_next_char_for_char width ib with
   | '\\' | '\'' | '\"' | 'n' | 't' | 'b' | 'r' as c ->
-    Scanning.store_char max ib (char_for_backslash c)
+    Scanning.store_char width ib (char_for_backslash c)
   | '0' .. '9' as c ->
     let get_digit () =
       let c = Scanning.next_char ib in
@@ -910,7 +911,7 @@ let scan_backslash_char max ib =
     let c0 = c in
     let c1 = get_digit () in
     let c2 = get_digit () in
-    Scanning.store_char (max - 2) ib (char_for_decimal_code c0 c1 c2)
+    Scanning.store_char (width - 2) ib (char_for_decimal_code c0 c1 c2)
   | 'x' ->
     let get_digit () =
       let c = Scanning.next_char ib in
@@ -919,68 +920,68 @@ let scan_backslash_char max ib =
       | c -> bad_input_escape c in
     let c1 = get_digit () in
     let c2 = get_digit () in
-    Scanning.store_char (max - 2) ib (char_for_hexadecimal_code c1 c2)
+    Scanning.store_char (width - 2) ib (char_for_hexadecimal_code c1 c2)
   | c ->
     bad_input_escape c
 ;;
 
-(* Scan a character (a Caml token). *)
-let scan_Char max ib =
+(* Scan a character (an OCaml token). *)
+let scan_Char width ib =
 
-  let rec find_start max =
+  let rec find_start width =
     match Scanning.checked_peek_char ib with
-    | '\'' -> find_char (Scanning.ignore_char max ib)
+    | '\'' -> find_char (Scanning.ignore_char width ib)
     | c -> character_mismatch '\'' c
 
-  and find_char max =
-    match check_next_char_for_char max ib with
-    | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char max ib) ib)
-    | c -> find_stop (Scanning.store_char max ib c)
+  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)
 
-  and find_stop max =
-    match check_next_char_for_char max ib with
-    | '\'' -> Scanning.ignore_char max ib
+  and find_stop width =
+    match check_next_char_for_char width ib with
+    | '\'' -> Scanning.ignore_char width ib
     | c -> character_mismatch '\'' c in
 
-  find_start max
+  find_start width
 ;;
 
-(* Scan a delimited string (a Caml token). *)
-let scan_String max ib =
+(* Scan a delimited string (an OCaml token). *)
+let scan_String width ib =
 
-  let rec find_start max =
+  let rec find_start width =
     match Scanning.checked_peek_char ib with
-    | '\"' -> find_stop (Scanning.ignore_char max ib)
+    | '\"' -> find_stop (Scanning.ignore_char width ib)
     | c -> character_mismatch '\"' c
 
-  and find_stop max =
-    match check_next_char_for_string max ib with
-    | '\"' -> Scanning.ignore_char max ib
-    | '\\' -> scan_backslash (Scanning.ignore_char max ib)
-    | c -> find_stop (Scanning.store_char max ib c)
+  and find_stop width =
+    match check_next_char_for_string width ib with
+    | '\"' -> Scanning.ignore_char width ib
+    | '\\' -> scan_backslash (Scanning.ignore_char width ib)
+    | c -> find_stop (Scanning.store_char width ib c)
 
-  and scan_backslash max =
-    match check_next_char_for_string max ib with
-    | '\r' -> skip_newline (Scanning.ignore_char max ib)
-    | '\n' -> skip_spaces (Scanning.ignore_char max ib)
-    | c -> find_stop (scan_backslash_char max ib)
+  and scan_backslash width =
+    match check_next_char_for_string width ib with
+    | '\r' -> skip_newline (Scanning.ignore_char width ib)
+    | '\n' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop (scan_backslash_char width ib)
 
-  and skip_newline max =
-    match check_next_char_for_string max ib with
-    | '\n' -> skip_spaces (Scanning.ignore_char max ib)
-    | _ -> find_stop (Scanning.store_char max ib '\r')
+  and skip_newline width =
+    match check_next_char_for_string width ib with
+    | '\n' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop (Scanning.store_char width ib '\r')
 
-  and skip_spaces max =
-    match check_next_char_for_string max ib with
-    | ' ' -> skip_spaces (Scanning.ignore_char max ib)
-    | _ -> find_stop max in
+  and skip_spaces width =
+    match check_next_char_for_string width ib with
+    | ' ' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop width in
 
-  find_start max
+  find_start width
 ;;
 
-(* Scan a boolean (a Caml token). *)
-let scan_bool max ib =
-  if max < 4 then bad_token_length "a boolean" else
+(* Scan a boolean (an OCaml token). *)
+let scan_bool width ib =
+  if width < 4 then bad_token_length "a boolean" else
   let c = Scanning.checked_peek_char ib in
   let m =
     match c with
@@ -989,7 +990,7 @@ let scan_bool max ib =
     | c ->
       bad_input
         (Printf.sprintf "the character %C cannot start a boolean" c) in
-  scan_string [] (min max m) ib
+  scan_string [] (min width m) ib
 ;;
 
 (* Reading char sets in %[...] conversions. *)
@@ -998,31 +999,51 @@ type char_set =
    | Neg_set of string (* Negative (complementary) set. *)
 ;;
 
+
 (* Char sets are read as sub-strings in the format string. *)
-let read_char_set fmt i =
-  let lim = Sformat.length fmt - 1 in
+let scan_range fmt j =
+
+  let len = Sformat.length fmt in
 
-  let rec find_in_set j =
-    if j > lim then incomplete_format fmt else
+  let buffer = Buffer.create len in
+
+  let rec scan_closing j =
+    if j >= len then incomplete_format fmt else
     match Sformat.get fmt j with
-    | ']' -> j
-    | c -> find_in_set (succ j)
-
-  and find_set i =
-    if i > lim then incomplete_format fmt else
-    match Sformat.get fmt i with
-    | ']' -> find_in_set (succ i)
-    | c -> find_in_set i in
-
-  if i > lim then incomplete_format fmt else
-  match Sformat.get fmt i with
-  | '^' ->
-    let i = succ i in
-    let j = find_set i in
-    j, Neg_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
-  | _ ->
-    let j = find_set i in
-    j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
+    | ']' -> j, Buffer.contents buffer
+    | '%' ->
+      let j = j + 1 in
+      if j >= len then incomplete_format fmt else
+      begin match Sformat.get fmt j with
+      | '%' | '@' as c ->
+        Buffer.add_char buffer c;
+        scan_closing (j + 1)
+      | c -> bad_conversion fmt j c
+      end
+    | c ->
+      Buffer.add_char buffer c;
+      scan_closing (j + 1) in
+
+  let scan_first_pos j =
+    if j >= len then incomplete_format fmt else
+    match Sformat.get fmt j with
+    | ']' as c ->
+      Buffer.add_char buffer c;
+      scan_closing (j + 1)
+    | _ -> scan_closing j in
+
+  let rec scan_first_neg j =
+    if j >= len then incomplete_format fmt else
+    match Sformat.get fmt j with
+    | '^' ->
+      let j = j + 1 in
+      let k, char_set = scan_first_pos j in
+      k, Neg_set char_set
+    | _ ->
+      let k, char_set = scan_first_pos j in
+      k, Pos_set char_set in
+
+  scan_first_neg j
 ;;
 
 (* Char sets are now represented as bit vectors that are represented as
@@ -1082,7 +1103,7 @@ let make_char_bit_vect bit set =
       for j = int_of_char c1 to int_of_char c2 do
         set_bit_of_range r j bit done;
       loop bit false (succ i)
-    | c ->
+    | _ ->
       set_bit_of_range r (int_of_char set.[i]) bit;
       loop bit true (succ i) in
   loop bit false 0;
@@ -1090,7 +1111,7 @@ let make_char_bit_vect bit set =
 ;;
 
 (* Compute the predicate on chars corresponding to a char set. *)
-let make_pred bit set stp =
+let make_predicate bit set stp =
   let r = make_char_bit_vect bit set in
   List.iter
     (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp;
@@ -1101,7 +1122,7 @@ let make_setp stp char_set =
   match char_set with
   | Pos_set set ->
     begin match String.length set with
-    | 0 -> (fun c -> 0)
+    | 0 -> (fun _ -> 0)
     | 1 ->
       let p = set.[0] in
       (fun c -> if c == p then 1 else 0)
@@ -1110,13 +1131,13 @@ let make_setp stp char_set =
       (fun c -> if c == p1 || c == p2 then 1 else 0)
     | 3 ->
       let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
-      if p2 = '-' then make_pred 1 set stp else
+      if p2 = '-' then make_predicate 1 set stp else
       (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0)
-    | n -> make_pred 1 set stp
+    | _ -> make_predicate 1 set stp
     end
   | Neg_set set ->
     begin match String.length set with
-    | 0 -> (fun c -> 1)
+    | 0 -> (fun _ -> 1)
     | 1 ->
       let p = set.[0] in
       (fun c -> if c != p then 1 else 0)
@@ -1125,9 +1146,9 @@ let make_setp stp char_set =
       (fun c -> if c != p1 && c != p2 then 1 else 0)
     | 3 ->
       let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
-      if p2 = '-' then make_pred 0 set stp else
+      if p2 = '-' then make_predicate 0 set stp else
       (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0)
-    | n -> make_pred 0 set stp
+    | _ -> make_predicate 0 set stp
     end
 ;;
 
@@ -1151,75 +1172,75 @@ let find_setp stp char_set =
     setp
 ;;
 
-let scan_chars_in_char_set stp char_set max ib =
-  let rec loop_pos1 cp1 max =
-    if max = 0 then max else
+let scan_chars_in_char_set stp char_set width ib =
+  let rec loop_pos1 cp1 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c == cp1
-    then loop_pos1 cp1 (Scanning.store_char max ib c)
-    else max
-  and loop_pos2 cp1 cp2 max =
-    if max = 0 then max else
+    then loop_pos1 cp1 (Scanning.store_char width ib c)
+    else width
+  and loop_pos2 cp1 cp2 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c == cp1 || c == cp2
-    then loop_pos2 cp1 cp2 (Scanning.store_char max ib c)
-    else max
-  and loop_pos3 cp1 cp2 cp3 max =
-    if max = 0 then max else
+    then loop_pos2 cp1 cp2 (Scanning.store_char width ib c)
+    else width
+  and loop_pos3 cp1 cp2 cp3 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c == cp1 || c == cp2 || c == cp3
-    then loop_pos3 cp1 cp2 cp3 (Scanning.store_char max ib c)
-    else max
-  and loop_neg1 cp1 max =
-    if max = 0 then max else
+    then loop_pos3 cp1 cp2 cp3 (Scanning.store_char width ib c)
+    else width
+  and loop_neg1 cp1 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c != cp1
-    then loop_neg1 cp1 (Scanning.store_char max ib c)
-    else max
-  and loop_neg2 cp1 cp2 max =
-    if max = 0 then max else
+    then loop_neg1 cp1 (Scanning.store_char width ib c)
+    else width
+  and loop_neg2 cp1 cp2 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c != cp1 && c != cp2
-    then loop_neg2 cp1 cp2 (Scanning.store_char max ib c)
-    else max
-  and loop_neg3 cp1 cp2 cp3 max =
-    if max = 0 then max else
+    then loop_neg2 cp1 cp2 (Scanning.store_char width ib c)
+    else width
+  and loop_neg3 cp1 cp2 cp3 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c != cp1 && c != cp2 && c != cp3
-    then loop_neg3 cp1 cp2 cp3 (Scanning.store_char max ib c)
-    else max
-  and loop setp max =
-    if max = 0 then max else
+    then loop_neg3 cp1 cp2 cp3 (Scanning.store_char width ib c)
+    else width
+  and loop setp width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if setp c == 1
-    then loop setp (Scanning.store_char max ib c)
-    else max in
+    then loop setp (Scanning.store_char width ib c)
+    else width in
 
-  let max =
+  let width =
     match char_set with
     | Pos_set set ->
       begin match String.length set with
-      | 0 -> loop (fun c -> 0) max
-      | 1 -> loop_pos1 set.[0] max
-      | 2 -> loop_pos2 set.[0] set.[1] max
-      | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max
-      | n -> loop (find_setp stp char_set) max end
+      | 0 -> loop (fun _ -> 0) width
+      | 1 -> loop_pos1 set.[0] width
+      | 2 -> loop_pos2 set.[0] set.[1] width
+      | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] width
+      | _ -> loop (find_setp stp char_set) width end
     | Neg_set set ->
       begin match String.length set with
-      | 0 -> loop (fun c -> 1) max
-      | 1 -> loop_neg1 set.[0] max
-      | 2 -> loop_neg2 set.[0] set.[1] max
-      | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
-      | n -> loop (find_setp stp char_set) max end in
+      | 0 -> loop (fun _ -> 1) width
+      | 1 -> loop_neg1 set.[0] width
+      | 2 -> loop_neg2 set.[0] set.[1] width
+      | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] width
+      | _ -> loop (find_setp stp char_set) width end in
   ignore_stoppers stp ib;
-  max
+  width
 ;;
 
 let get_count t ib =
@@ -1305,7 +1326,7 @@ let scan_format ib ef fmt rv f =
   let return v = Obj.magic v () in
   let delay f x () = f x in
   let stack f = delay (return f) in
-  let no_stack f x = f in
+  let no_stack f _x = f in
 
   let rec scan fmt =
 
@@ -1313,14 +1334,9 @@ let scan_format ib ef fmt rv f =
 
     let rec scan_fmt ir f i =
       if i > lim then ir, f else
-      match Sformat.get fmt i with
-      | ' ' -> skip_whites ib; scan_fmt ir f (succ i)
+      match Sformat.unsafe_get fmt i with
       | '%' -> scan_skip ir f (succ i)
-      | '@' ->
-        let i = succ i in
-        if i > lim then incomplete_format fmt else begin
-        check_char ib (Sformat.get fmt i);
-        scan_fmt ir f (succ i) end
+      | ' ' -> skip_whites ib; scan_fmt ir f (succ i)
       | c -> check_char ib c; scan_fmt ir f (succ i)
 
     and scan_skip ir f i =
@@ -1330,78 +1346,88 @@ let scan_format ib ef fmt rv f =
       | _ -> scan_limits false ir f i
 
     and scan_limits skip ir f i =
-      if i > lim then ir, f else
-      let max_opt, min_opt, i =
+
+      let rec scan_width i =
+        if i > lim then incomplete_format fmt else
         match Sformat.get fmt i with
         | '0' .. '9' as conv ->
-          let rec read_width accu i =
-            if i > lim then accu, i else
-            match Sformat.get fmt i with
-            | '0' .. '9' as c ->
-              let accu = 10 * accu + decimal_value_of_char c in
-              read_width accu (succ i)
-            | _ -> accu, i in
-
-          let max, i = read_width (decimal_value_of_char conv) (succ i) in
-
-          if i > lim then incomplete_format fmt else
-          begin
-            match Sformat.get fmt i with
-            | '.' ->
-              let min, i = read_width 0 (succ i) in
-              (Some max, Some min, i)
-            | _ -> Some max, None, i
-          end
-        | _ -> None, None, i in
+          let width, i = read_int_literal (decimal_value_of_char conv) (succ i) in
+          Some width, i
+        | _ -> None, i
+
+      and scan_precision i =
+        begin
+          match Sformat.get fmt i with
+          | '.' ->
+            let precision, i = read_int_literal 0 (succ i) in
+            (Some precision, i)
+          | _ -> None, i
+        end
 
-      scan_conversion skip max_opt min_opt ir f i
+      and read_int_literal accu i =
+        if i > lim then accu, i else
+        match Sformat.unsafe_get fmt i with
+        | '0' .. '9' as c ->
+          let accu = 10 * accu + decimal_value_of_char c in
+          read_int_literal accu (succ i)
+        | _ -> accu, i in
 
-    and scan_conversion skip max_opt min_opt ir f i =
+      if i > lim then ir, f else
+      let width_opt, i = scan_width i in
+      let prec_opt, i = scan_precision i in
+      scan_conversion skip width_opt prec_opt ir f i
+
+    and scan_conversion skip width_opt prec_opt ir f i =
       let stack = if skip then no_stack else stack in
-      let max = int_max max_opt in
-      let min = int_min min_opt in
+      let width = int_of_width_opt width_opt in
+      let prec = int_of_prec_opt prec_opt in
       match Sformat.get fmt i with
-      | '%' as conv ->
-        check_char ib conv; scan_fmt ir f (succ i)
+      | '%' | '@' as c ->
+        check_char ib c;
+        scan_fmt ir f (succ i)
+      | '!' ->
+        if not (Scanning.end_of_input ib)
+        then bad_input "end of input not found" else
+        scan_fmt ir f (succ i)
+      | ',' ->
+        scan_fmt ir f (succ i)
       | 's' ->
-        let i, stp = scan_fmt_stoppers (succ i) in
-        let _x = scan_string stp max ib in
+        let i, stp = scan_indication (succ i) in
+        let _x = scan_string stp width ib in
         scan_fmt ir (stack f (token_string ib)) (succ i)
       | 'S' ->
-        let _x = scan_String max ib in
+        let _x = scan_String width ib in
         scan_fmt ir (stack f (token_string ib)) (succ i)
       | '[' (* ']' *) ->
-        let i, char_set = read_char_set fmt (succ i) in
-        let i, stp = scan_fmt_stoppers (succ i) in
-        let _x = scan_chars_in_char_set stp char_set max ib in
+        let i, char_set = scan_range fmt (succ i) in
+        let i, stp = scan_indication (succ i) in
+        let _x = scan_chars_in_char_set stp char_set width ib in
         scan_fmt ir (stack f (token_string ib)) (succ i)
-      | ('c' | 'C') when max = 0 ->
+      | ('c' | 'C') when width = 0 ->
         let c = Scanning.checked_peek_char ib in
         scan_fmt ir (stack f c) (succ i)
       | 'c' ->
-        let _x = scan_char max ib in
+        let _x = scan_char width ib in
         scan_fmt ir (stack f (token_char ib)) (succ i)
       | 'C' ->
-        let _x = scan_Char max ib in
+        let _x = scan_Char width ib in
         scan_fmt ir (stack f (token_char ib)) (succ i)
       | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
-        let _x = scan_int_conv conv max min ib in
+        let _x = scan_int_conv conv width prec ib in
         scan_fmt ir (stack f (token_int conv ib)) (succ i)
       | 'N' as conv ->
         scan_fmt ir (stack f (get_count conv ib)) (succ i)
       | 'f' | 'e' | 'E' | 'g' | 'G' ->
-        let min = float_min min_opt in
-        let _x = scan_float max min ib in
+        let _x = scan_float width prec ib in
         scan_fmt ir (stack f (token_float ib)) (succ i)
       | 'F' ->
-        let min = float_min min_opt in
-        let _x = scan_Float max min ib in
+        let _x = scan_Float width prec ib in
         scan_fmt ir (stack f (token_float ib)) (succ i)
-(*      | 'B' | 'b' when max = Some 0 ->
-        let _x = scan_bool max ib in
+(*      | 'B' | 'b' when width = Some 0 ->
+        let _x = scan_bool width ib in
         scan_fmt ir (stack f (token_int ib)) (succ i) *)
       | 'B' | 'b' ->
-        let _x = scan_bool max ib in
+        let _x = scan_bool width ib in
         scan_fmt ir (stack f (token_bool ib)) (succ i)
       | 'r' ->
         if ir > limr then assert false else
@@ -1413,7 +1439,7 @@ let scan_format ib ef fmt rv f =
         match Sformat.get fmt i with
         (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *)
         | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv1 ->
-          let _x = scan_int_conv conv1 max min ib in
+          let _x = scan_int_conv conv1 width prec ib in
           (* Look back to the character that triggered the integer conversion
              (this character is either 'l', 'n' or 'L') to find the
              conversion to apply to the integer token read. *)
@@ -1423,11 +1449,6 @@ let scan_format ib ef fmt rv f =
           | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end
         (* This is not an integer conversion, but a regular %l, %n or %L. *)
         | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end
-      | '!' ->
-        if Scanning.end_of_input ib then scan_fmt ir f (succ i)
-        else bad_input "end of input not found"
-      | ',' ->
-        scan_fmt ir f (succ i)
       | '(' | '{' as conv (* ')' '}' *) ->
         let i = succ i in
         (* Find the static specification for the format to read. *)
@@ -1437,7 +1458,7 @@ let scan_format ib ef fmt rv f =
         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. *)
-        let _x = scan_String max ib in
+        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
         (* For conversion %{%}, just return this format string as the token
@@ -1451,12 +1472,23 @@ let scan_format ib ef fmt rv f =
 
       | c -> bad_conversion fmt i c
 
-    and scan_fmt_stoppers i =
-      if i > lim then i - 1, [] else
-      match Sformat.get fmt i with
-      | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i]
-      | '@' when i = lim -> incomplete_format fmt
-      | _ -> i - 1, [] in
+    and scan_indication j =
+      if j > lim then j - 1, [] else
+      match Sformat.get fmt j with
+      | '@' ->
+        let k = j + 1 in
+        if k > lim then j - 1, [] else
+        begin match Sformat.get fmt k with
+        | '%' ->
+          let k = k + 1 in
+          if k > lim then j - 1, [] else
+          begin match Sformat.get fmt k with
+          | '%' | '@' as c  -> k, [ c ]
+          | _c -> j - 1, []
+          end
+        | c -> k, [ c ]
+        end
+      | _c -> j - 1, [] in
 
     scan_fmt in
 
@@ -1481,7 +1513,8 @@ let bscanf ib = kscanf ib scanf_bad_input;;
 
 let fscanf ic = bscanf (Scanning.from_channel ic);;
 
-let sscanf s = bscanf (Scanning.from_string s);;
+let sscanf : string -> ('a, 'b, 'c, 'd) scanner
+  = fun s -> bscanf (Scanning.from_string s);;
 
 let scanf fmt = bscanf Scanning.stdib fmt;;
 
@@ -1513,3 +1546,12 @@ let string_to_String s =
 let format_from_string s fmt =
   sscanf_format (string_to_String s) fmt (fun x -> x)
 ;;
+
+let unescaped s =
+  sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
+
+(*
+ Local Variables:
+  compile-command: "cd ..; make world"
+  End:
+*)
diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index 2a3bf4fd..c147f7a0 100644
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -25,7 +25,8 @@
     strings, files, or anything that can return characters. The more general
     source of characters is named a {e formatted input channel} (or {e
     scanning buffer}) and has type {!Scanning.in_channel}. The more general
-    formatted input function reads from any scanning buffer and is named [bscanf].
+    formatted input function reads from any scanning buffer and is named
+    [bscanf].
 
     Generally speaking, the formatted input functions have 3 arguments:
     - the first argument is a source of characters for the input,
@@ -58,30 +59,31 @@
 
     - if we define the receiver [f] as [let f x = x + 1],
 
-    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. *)
+    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. *)
 
 (** {7 Formatted input as a functional feature} *)
 
-(** The Caml scanning facility is reminiscent of the corresponding C feature.
+(** The OCaml scanning facility is reminiscent of the corresponding C feature.
     However, it is also largely different, simpler, and yet more powerful:
     the formatted input functions are higher-order functionals and the
     parameter passing mechanism is just the regular function application not
     the variable assignment based mechanism which is typical for formatted
-    input in imperative languages; the Caml format strings also feature
+    input in imperative languages; the OCaml format strings also feature
     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 Caml formatted input
+    polymorphic user-defined scanners.  Furthermore, the OCaml formatted input
     facility is fully type-checked at compile time. *)
 
 (** {6 Formatted input channel} *)
+
 module Scanning : sig
 
 type in_channel;;
-(* The notion of input channel for the [Scanf] module:
+(** The notion of input channel for the [Scanf] module:
    those channels provide all the machinery necessary to read from a given
    [Pervasives.in_channel] value.
    A [Scanf.Scanning.in_channel] value is also called a {i formatted input
@@ -114,7 +116,12 @@ val stdin : in_channel;;
     @since 3.12.0
 *)
 
-val open_in : string -> in_channel;;
+type file_name = string;;
+(** A convenient alias to designate a file name.
+    @since 4.00.0
+*)
+
+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].
 
@@ -126,9 +133,9 @@ val open_in : string -> in_channel;;
     @since 3.12.0
 *)
 
-val open_in_bin : string -> in_channel;;
-(** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized
-    reading in binary mode of file [fname].
+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].
     @since 3.12.0
 *)
 
@@ -138,7 +145,7 @@ val close_in : in_channel -> unit;;
   @since 3.12.0
 *)
 
-val from_file : string -> in_channel;;
+val from_file : file_name -> in_channel;;
 (** An alias for [open_in] above. *)
 val from_file_bin : string -> in_channel;;
 (** An alias for [open_in_bin] above. *)
@@ -187,12 +194,13 @@ end;;
 
 type ('a, 'b, 'c, 'd) scanner =
      ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;;
-(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the
-    type of a formatted input function that reads from some formatted input channel
-    according to some format string; more precisely, if [scan] is some
-    formatted input function, then [scan ic fmt f] applies [f] to the arguments
-    specified by the format string [fmt], when [scan] has read those arguments
-    from the formatted input channel [ic].
+(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner]
+    is the type of a formatted input function that reads from some
+    formatted input channel according to some format string; more
+    precisely, if [scan] is some formatted input function, then [scan
+    ic fmt f] applies [f] to the arguments specified by the format
+    string [fmt], when [scan] has read those arguments from the
+    formatted input channel [ic].
 
     For instance, the [scanf] function below has type [('a, 'b, 'c, 'd)
     scanner], since it is a formatted input function that reads from
@@ -268,7 +276,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
        ([0x[0-9a-f]+] and [0X[0-9A-F]+]), octal ([0o[0-7]+]), and binary
        ([0b[0-1]+]) notations are understood).
     - [u]: reads an unsigned decimal integer.
-    - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-f]+] or [[0-9A-F]+]).
+    - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-fA-F]+]).
     - [o]: reads an unsigned octal integer ([[0-7]+]).
     - [s]: reads a string argument that spreads as much as possible, until the
       following bounding condition holds: {ul
@@ -277,20 +285,20 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
          encountered,}
       {- the end-of-input has been reached.}}
       Hence, this conversion always succeeds: it returns an empty
-      string, if the bounding condition holds when the scan begins.
+      string if the bounding condition holds when the scan begins.
     - [S]: reads a delimited string argument (delimiters and special
-      escaped characters follow the lexical conventions of Caml).
+      escaped characters follow the lexical conventions of OCaml).
     - [c]: reads a single character. To test the current input character
       without reading it, specify a null field width, i.e. use
       specification [%0c]. Raise [Invalid_argument], if the field width
       specification is greater than 1.
     - [C]: reads a single delimited character (delimiters and special
-      escaped characters follow the lexical conventions of Caml).
+      escaped characters follow the lexical conventions of OCaml).
     - [f], [e], [E], [g], [G]: reads an optionally signed
       floating-point number in decimal notation, in the style [dddd.ddd
       e/E+-dd].
     - [F]: reads a floating point number according to the lexical
-      conventions of Caml (hence the decimal point is mandatory if the
+      conventions of OCaml (hence the decimal point is mandatory if the
       exponent part is not mentioned).
     - [B]: reads a boolean argument ([true] or [false]).
     - [b]: reads a boolean argument (for backward compatibility; do not use
@@ -313,17 +321,17 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
       first character of the range (or just after the [^] in case of
       range negation); hence [\[\]\]] matches a [\]] character and
       [\[^\]\]] matches any character that is not [\]].
-    - [r]: user-defined reader. Takes the next [ri] formatted input 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 read must have the same type as the format string
-      specification [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"].
+      Use [%%] and [%\@] to include a [%] or a [\@] in a range.
+    - [r]: user-defined reader. Takes the next [ri] formatted input
+      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
+      read must have the same type as the format string specification
+      [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].
@@ -347,7 +355,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     - [N] or [L]: returns the number of tokens read so far.
     - [!]: matches the end of input condition.
     - [%]: matches one [%] character in the input.
-    - [,]: the no-op delimiter for conversion specifications.
+    - [\@]: matches one [\@] character in the input.
+    - [,]: does nothing.
 
     Following the [%] character that introduces a conversion, there may be
     the special flag [_]: the conversion that follows occurs as usual,
@@ -358,7 +367,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     The field width is composed of an optional integer literal
     indicating the maximal width of the token to read.
     For instance, [%6d] reads an integer, having at most 6 decimal digits;
-    [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]]
+    [%4f] reads a float with at most 4 characters; and [%8[\\000-\\255]]
     returns the next 8 characters (or all the characters still available,
     if fewer than 8 characters are available in the input).
 
@@ -368,7 +377,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
       nothing to read in the input: in this case, it simply returns [""].
 
     - in addition to the relevant digits, ['_'] characters may appear
-    inside numbers (this is reminiscent to the usual Caml lexical
+    inside numbers (this is reminiscent to the usual OCaml lexical
     conventions). If stricter scanning is desired, use the range
     conversion facility instead of the number conversions.
 
@@ -381,19 +390,22 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
 (** {7:indication Scanning indications in format strings} *)
 
 (** Scanning indications appear just after the string conversions [%s]
-    and [%\[ range \]] to delimit the end of the token. A scanning
-    indication is introduced by a [@] character, followed by some
-    constant character [c]. It means that the string token should end
+    and [%[ range ]] to delimit the end of the token. A scanning
+    indication is introduced by a [\@] character, followed by some
+    plain character [c]. It means that the string token should end
     just before the next matching [c] (which is skipped). If no [c]
     character is encountered, the string token spreads as much as
     possible. For instance, ["%s@\t"] reads a string up to the next
-    tab character or to the end of input. If a scanning
-    indication [\@c] does not follow a string conversion, it is treated
-    as a plain [c] character.
+    tab character or to the end of input. If a [\@] character appears
+    anywhere else in the format string, it is treated as a plain character.
 
     Note:
 
-    - the scanning indications introduce slight differences in the syntax of
+    - 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.
+    - 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
     the [Format] module; hence, when producing formatted text to be scanned
@@ -420,7 +432,8 @@ 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. *)
+    simply returns the characters read so far, or [""] if none were ever read.
+    *)
 
 (** {6 Specialised formatted input functions} *)
 
@@ -482,3 +495,11 @@ val format_from_string :
     have the same type as [fmt].
     @since 3.10.0
 *)
+
+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
+    argument, still return a copy, contrary to String.escaped.
+    @since 4.00.0
+*)
diff --git a/stdlib/set.ml b/stdlib/set.ml
index 375fc5d0..e61fd24b 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -117,13 +117,32 @@ module Make(Ord: OrderedType) =
           if c = 0 then t else
           if c < 0 then bal (add x l) v r else bal l v (add x r)
 
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    (* Beware: those two functions assume that the added v is *strictly*
+       smaller (or bigger) than all the present elements in the tree; it
+       does not test for equality with the current min (or max) element.
+       Indeed, they are only used during the "join" operation which
+       respects this precondition.
+    *)
+
+    let rec add_min_element v = function
+      | Empty -> singleton v
+      | Node (l, x, r, h) ->
+        bal (add_min_element v l) x r
+
+    let rec add_max_element v = function
+      | Empty -> singleton v
+      | Node (l, x, r, h) ->
+        bal l x (add_max_element v r)
+
     (* Same as create and bal, but no assumptions are made on the
        relative heights of l and r. *)
 
     let rec join l v r =
       match (l, r) with
-        (Empty, _) -> add v r
-      | (_, Empty) -> add v l
+        (Empty, _) -> add_min_element v r
+      | (_, Empty) -> add_max_element v l
       | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
           if lh > rh + 2 then bal ll lv (join lr v r) else
           if rh > lh + 2 then bal (join l v rl) rv rr else
@@ -197,8 +216,6 @@ module Make(Ord: OrderedType) =
           let c = Ord.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
-    let singleton x = Node(Empty, x, Empty, 1)
-
     let rec remove x = function
         Empty -> Empty
       | Node(l, v, r, _) ->
@@ -300,19 +317,19 @@ module Make(Ord: OrderedType) =
         Empty -> false
       | Node(l, v, r, _) -> p v || exists p l || exists p r
 
-    let filter p s =
-      let rec filt accu = function
-        | Empty -> accu
-        | Node(l, v, r, _) ->
-            filt (filt (if p v then add v accu else accu) l) r in
-      filt Empty s
-
-    let partition p s =
-      let rec part (t, f as accu) = function
-        | Empty -> accu
-        | Node(l, v, r, _) ->
-            part (part (if p v then (add v t, f) else (t, add v f)) l) r in
-      part (Empty, Empty) s
+    let rec filter p = function
+        Empty -> Empty
+      | Node(l, v, r, _) ->
+          let l' = filter p l and r' = filter p r in
+          if p v then join l' v r' else concat l' r'
+
+    let rec partition p = function
+        Empty -> (Empty, Empty)
+      | Node(l, v, r, _) ->
+          let (lt, lf) = partition p l and (rt, rf) = partition p r in
+          if p v
+          then (join lt v rt, concat lf rf)
+          else (concat lt rt, join lf v rf)
 
     let rec cardinal = function
         Empty -> 0
diff --git a/stdlib/set.mli b/stdlib/set.mli
index 851a9ef5..0f1a3b7c 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/sort.ml b/stdlib/sort.ml
index 7c53ab77..66546b12 100644
--- a/stdlib/sort.ml
+++ b/stdlib/sort.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/sort.mli b/stdlib/sort.mli
index 7069052e..4f2a961a 100644
--- a/stdlib/sort.mli
+++ b/stdlib/sort.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/stack.ml b/stdlib/stack.ml
index 03277d07..599b10c8 100644
--- a/stdlib/stack.ml
+++ b/stdlib/stack.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/stack.mli b/stdlib/stack.mli
index bf33d01a..2d7a9006 100644
--- a/stdlib/stack.mli
+++ b/stdlib/stack.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml
index bd6a5841..468dd517 100644
--- a/stdlib/stdLabels.ml
+++ b/stdlib/stdLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
index 73f72dc6..1360081a 100644
--- a/stdlib/stdLabels.mli
+++ b/stdlib/stdLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
@@ -117,6 +117,7 @@ module String :
         unit
     val concat : sep:string -> string list -> string
     val iter : f:(char -> unit) -> string -> unit
+    val trim : string -> string
     val escaped : string -> string
     val index : string -> char -> int
     val rindex : string -> char -> int
diff --git a/stdlib/std_exit.ml b/stdlib/std_exit.ml
index 6f5ff301..c5615373 100644
--- a/stdlib/std_exit.ml
+++ b/stdlib/std_exit.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/stdlib/stream.ml b/stdlib/stream.ml
index aa6a2a2a..fc66acb3 100644
--- a/stdlib/stream.ml
+++ b/stdlib/stream.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                             Ocaml                                   *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
diff --git a/stdlib/stream.mli b/stdlib/stream.mli
index 28cfd3a1..16e71179 100644
--- a/stdlib/stream.mli
+++ b/stdlib/stream.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                             Ocaml                                   *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -27,12 +27,7 @@ exception Error of string
    accepted, but one of the following components is rejected. *)
 
 
-(** {6 Stream builders}
-
-   Warning: these functions create streams with fast access; it is illegal
-   to mix them with streams built with [[< >]]; would raise [Failure]
-   when accessing such mixed streams.
-*)
+(** {6 Stream builders} *)
 
 val from : (int -> 'a option) -> 'a t
 (** [Stream.from f] returns a stream built from the function [f].
@@ -90,7 +85,7 @@ val npeek : int -> 'a t -> 'a list
 
 (**/**)
 
-(** {6 For system use only, not for the casual user} *)
+(* The following is for system use only. Do not call directly. *)
 
 val iapp : 'a t -> 'a t -> 'a t
 val icons : 'a -> 'a t -> 'a t
diff --git a/stdlib/string.ml b/stdlib/string.ml
index 0e55ff46..f3906f35 100644
--- a/stdlib/string.ml
+++ b/stdlib/string.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -60,6 +60,9 @@ let blit s1 ofs1 s2 ofs2 len =
 let iter f a =
   for i = 0 to length a - 1 do f(unsafe_get a i) done
 
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
 let concat sep l =
   match l with
     [] -> ""
@@ -82,6 +85,27 @@ external is_printable: char -> bool = "caml_is_printable"
 external char_code: char -> int = "%identity"
 external char_chr: int -> char = "%identity"
 
+let is_space = function
+  | ' ' | '\012' | '\n' | '\r' | '\t' -> true
+  | _ -> false
+
+let trim s =
+  let len = length s in
+  let i = ref 0 in
+  while !i < len && is_space (unsafe_get s !i) do
+    incr i
+  done;
+  let j = ref (len - 1) in
+  while !j >= !i && is_space (unsafe_get s !j) do
+    decr j
+  done;
+  if !i = 0 && !j = len - 1 then
+    s
+  else if !j >= !i then
+    sub s !i (!j - !i + 1)
+  else
+    ""
+
 let escaped s =
   let n = ref 0 in
     for i = 0 to length s - 1 do
diff --git a/stdlib/string.mli b/stdlib/string.mli
index 21bfb7c0..c248fab1 100644
--- a/stdlib/string.mli
+++ b/stdlib/string.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,6 +14,7 @@
 (* $Id$ *)
 
 (** String operations.
+
   Given a string [s] of length [l], we call character number in [s]
   the index of a character in [s].  Indexes start at [0], and we will
   call a character number valid in [s] if it falls within the range
@@ -25,6 +26,31 @@
   Two parameters [start] and [len] are said to designate a valid
   substring of [s] if [len >= 0] and [start] and [start+len] are
   valid positions in [s].
+
+  OCaml strings can be modified in place, for instance via the
+  {!String.set} and {!String.blit} functions described below.  This
+  possibility should be used rarely and with much care, however, since
+  both the OCaml compiler and most OCaml libraries share strings as if
+  they were immutable, rather than copying them.  In particular,
+  string literals are shared: a single copy of the string is created
+  at program loading time and returned by all evaluations of the
+  string literal.  Consider for example:
+
+  {[
+      # let f () = "foo";;
+      val f : unit -> string = 
+      # (f ()).[0] <- 'b';;
+      - : unit = ()
+      # f ();;
+      - : string = "boo"
+  ]}
+
+  Likewise, many functions from the standard library can return string
+  literals or one of their string arguments.  Therefore, the returned strings
+  must not be modified directly.  If mutation is absolutely necessary,
+  it should be performed on a fresh copy of the string, as produced by
+  {!String.copy}.
+
  *)
 
 external length : string -> int = "%string_length"
@@ -94,12 +120,33 @@ val iter : (char -> unit) -> string -> unit
    the characters of [s].  It is equivalent to
    [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
 
+val iteri : (int -> char -> unit) -> string -> unit
+(** Same as {!String.iter}, but the
+   function is applied to the index of the element as first argument
+   (counting from 0), and the character itself as second argument.
+   @since 4.00.0
+*)
+
+val map : (char -> char) -> string -> string
+(** [String.map f s] applies function [f] in turn to all
+   the characters of [s] and stores the results in a new string that
+   is returned.
+   @since 4.00.0 *)
+
+val trim : string -> string
+(** Return a copy of the argument, without leading and trailing
+   whitespace.  The characters regarded as whitespace are: [' '],
+   ['\012'], ['\n'], ['\r'], and ['\t'].  If there is no leading nor
+   trailing whitespace character in the argument, return the original
+   string itself, not a copy.
+   @since 4.00.0 *)
+
 val escaped : string -> string
 (** Return a copy of the argument, with special characters
    represented by escape sequences, following the lexical
-   conventions of Objective Caml.  If there is no special
+   conventions of OCaml.  If there is no special
    character in the argument, return the original string itself,
-   not a copy. *)
+   not a copy. Its inverse function is Scanf.unescaped. *)
 
 val index : string -> char -> int
 (** [String.index s c] returns the character number of the first
@@ -176,6 +223,8 @@ val compare: t -> t -> int
 
 (**/**)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit :
diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml
index 87d23d86..2345d499 100644
--- a/stdlib/stringLabels.ml
+++ b/stdlib/stringLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
index 9cbee708..59b0eb7c 100644
--- a/stdlib/stringLabels.mli
+++ b/stdlib/stringLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -84,10 +84,30 @@ val iter : f:(char -> unit) -> string -> unit
    the characters of [s].  It is equivalent to
    [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
 
+val iteri : f:(int -> char -> unit) -> string -> unit
+(** Same as {!String.iter}, but the
+   function is applied to the index of the element as first argument
+   (counting from 0), and the character itself as second argument.
+   @since 4.00.0
+*)
+
+val map : f:(char -> char) -> string -> string
+(** [String.map f s] applies function [f] in turn to all
+   the characters of [s] and stores the results in a new string that
+   is returned.
+   @since 4.00.0 *)
+
+val trim : string -> string
+(** Return a copy of the argument, without leading and trailing whitespace.
+   The characters regarded as whitespace are: [' '], ['\012'], ['\n'],
+   ['\r'], and ['\t'].  If there is no whitespace character in the argument,
+   return the original string itself, not a copy.
+   @since 4.00.0 *)
+
 val escaped : string -> string
 (** Return a copy of the argument, with special characters
    represented by escape sequences, following the lexical
-   conventions of Objective Caml.  If there is no special
+   conventions of OCaml.  If there is no special
    character in the argument, return the original string itself,
    not a copy. *)
 
@@ -155,6 +175,8 @@ val compare: t -> t -> int
 
 (**/**)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit :
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index 713038aa..6f3d5797 100644
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,15 +75,19 @@ val interactive : bool ref
    the interactive toplevel system [ocaml]. *)
 
 val os_type : string
-(** Operating system currently executing the Caml program. One of
+(** Operating system currently executing the OCaml program. One of
 -  ["Unix"] (for all Unix versions, including Linux and Mac OS X),
 -  ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
 -  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
 
 val word_size : int
-(** Size of one word on the machine currently executing the Caml
+(** Size of one word on the machine currently executing the OCaml
    program, in bits: 32 or 64. *)
 
+val big_endian : bool
+(** Whether the machine currently executing the Caml program is big-endian.
+    @since 4.00.0 *)
+
 val max_string_length : int
 (** Maximum length of a string. *)
 
@@ -199,7 +203,7 @@ val catch_break : bool -> unit
 
 
 val ocaml_version : string;;
-(** [ocaml_version] is the version of Objective Caml.
+(** [ocaml_version] is the version of OCaml.
     It is a string of the form ["major.minor[.patchlevel][+additional-info]"],
     where [major], [minor], and [patchlevel] are integers, and
     [additional-info] is an arbitrary string. The [[.patchlevel]] and
diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp
index b58ca0bb..c7271794 100644
--- a/stdlib/sys.mlp
+++ b/stdlib/sys.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,11 +19,11 @@
 
 (* System interface *)
 
-external get_config: unit -> string * int = "caml_sys_get_config"
+external get_config: unit -> string * int * bool = "caml_sys_get_config"
 external get_argv: unit -> string * string array = "caml_sys_get_argv"
 
 let (executable_name, argv) = get_argv()
-let (os_type, word_size) = get_config()
+let (os_type, word_size, big_endian) = get_config()
 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 4adacd8e..bbd3debc 100644
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 33f4bf1d..add9b0ab 100644
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
diff --git a/testlabl/.cvsignore b/testlabl/.cvsignore
deleted file mode 100644
index 4c57147b..00000000
--- a/testlabl/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.out *.out2
\ No newline at end of file
diff --git a/testlabl/coerce.diffs b/testlabl/coerce.diffs
deleted file mode 100644
index e90e1fc9..00000000
--- a/testlabl/coerce.diffs
+++ /dev/null
@@ -1,93 +0,0 @@
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.201
-diff -u -r1.201 ctype.ml
---- typing/ctype.ml	5 Apr 2006 02:28:13 -0000	1.201
-+++ typing/ctype.ml	17 May 2006 23:48:22 -0000
-@@ -490,6 +490,31 @@
-     unmark_class_signature sign;
-     Some reason
- 
-+(* Variant for checking principality *)
-+
-+let rec free_nodes_rec ty =
-+  let ty = repr ty in
-+  if ty.level >= lowest_level then begin
-+    if ty.level <= !current_level then raise Exit;
-+    ty.level <- pivot_level - ty.level;
-+    begin match ty.desc with
-+      Tvar ->
-+        raise Exit
-+    | Tobject (ty, _) ->
-+        free_nodes_rec ty
-+    | Tfield (_, _, ty1, ty2) ->
-+        free_nodes_rec ty1; free_nodes_rec ty2
-+    | Tvariant row ->
-+        let row = row_repr row in
-+        iter_row free_nodes_rec {row with row_bound = []};
-+        if not (static_row row) then free_nodes_rec row.row_more
-+    | _    ->
-+        iter_type_expr free_nodes_rec ty
-+    end;
-+  end
-+
-+let has_free_nodes ty =
-+  try free_nodes_rec ty; false with Exit -> true
- 
-                             (**********************)
-                             (*  Type duplication  *)
-Index: typing/ctype.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
-retrieving revision 1.54
-diff -u -r1.54 ctype.mli
---- typing/ctype.mli	5 Apr 2006 02:28:13 -0000	1.54
-+++ typing/ctype.mli	17 May 2006 23:48:22 -0000
-@@ -228,6 +228,9 @@
- val closed_class:
-         type_expr list -> class_signature -> closed_class_failure option
-         (* Check whether all type variables are bound *)
-+val has_free_nodes: type_expr -> bool
-+        (* Check whether there are free type variables, or nodes with
-+           level lower or equal to !current_level *)
- 
- val unalias: type_expr -> type_expr
- val signature_of_class_type: class_type -> class_signature
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.181
-diff -u -r1.181 typecore.ml
---- typing/typecore.ml	16 Apr 2006 23:28:22 -0000	1.181
-+++ typing/typecore.ml	17 May 2006 23:48:22 -0000
-@@ -1183,12 +1183,29 @@
-             let (ty', force) =
-               Typetexp.transl_simple_type_delayed env sty'
-             in
-+            if !Clflags.principal then begin_def ();
-             let arg = type_exp env sarg in
-+            let has_fv =
-+              if !Clflags.principal then begin
-+                end_def ();
-+                let b = has_free_nodes arg.exp_type in
-+                Ctype.unify env arg.exp_type (newvar ());
-+                b
-+              end else
-+                free_variables arg.exp_type <> []
-+            in
-             begin match arg.exp_desc, !self_coercion, (repr ty').desc with
-               Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
-               Tconstr(path',_,_) when Path.same path path' ->
-                 r := sexp.pexp_loc :: !r;
-                 force ()
-+            | _ when not has_fv ->
-+                begin try
-+                  let force' = subtype env arg.exp_type ty' in
-+                  force (); force' ()
-+                with Subtype (tr1, tr2) ->
-+                  raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
-+                end
-             | _ ->
-                 let ty, b = enlarge_type env ty' in
-                 force ();
diff --git a/testlabl/dirs_multimatch b/testlabl/dirs_multimatch
deleted file mode 100644
index b4495146..00000000
--- a/testlabl/dirs_multimatch
+++ /dev/null
@@ -1 +0,0 @@
-parsing typing bytecomp driver toplevel
\ No newline at end of file
diff --git a/testlabl/dirs_poly b/testlabl/dirs_poly
deleted file mode 100644
index 3aec606e..00000000
--- a/testlabl/dirs_poly
+++ /dev/null
@@ -1 +0,0 @@
-bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml
diff --git a/testlabl/els.ml b/testlabl/els.ml
deleted file mode 100644
index fdd292d6..00000000
--- a/testlabl/els.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(* Adapted from: An Expressive Language of Signatures
-   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
-
-module type VALUE = sig
-  type value (* a Lua value *)
-  type state (* the state of a Lua interpreter *)
-  type usert (* a user-defined value *)
-end
-
-module type CORE0 = sig
-  module V : VALUE
-  val setglobal : V.state -> string -> V.value -> unit
-  (* five more functions common to core and evaluator *)
-end
-
-module type CORE = sig
-  include CORE0
-  val apply : V.value -> V.state -> V.value list -> V.value
-  (* apply function f in state s to list of args *)
-end
-
-module type AST = sig
-  module Value : VALUE
-  type chunk
-  type program
-  val get_value : chunk -> Value.value
-end
-
-module type EVALUATOR = sig
-  module Value : VALUE
-  module Ast : (AST with module Value := Value)
-  type state = Value.state
-  type value = Value.value
-  exception Error of string
-  val compile : Ast.program -> string
-  include CORE0 with module V := Value
-end
-
-module type PARSER = sig
-  type chunk
-  val parse : string -> chunk
-end
-
-module type INTERP = sig
-  include EVALUATOR
-  module Parser : PARSER with type chunk = Ast.chunk
-  val dostring : state -> string -> value list
-  val mk	: unit -> state
-end
-
-module type USERTYPE = sig
-  type t
-  val eq	: t -> t -> bool
-  val to_string : t -> string
-end
-
-module type TYPEVIEW = sig
-  type combined
-  type t
-  val map : (combined -> t) * (t -> combined)
-end
-
-module type COMBINED_COMMON = sig
-  module T : sig type t end
-  module TV1 : TYPEVIEW with type combined := T.t
-  module TV2 : TYPEVIEW with type combined := T.t
-end
-
-module type COMBINED_TYPE = sig
-  module T : USERTYPE
-  include COMBINED_COMMON with module T := T
-end
-
-module type BARECODE = sig
-  type state
-  val init : state -> unit
-end
-
-module USERCODE(X : TYPEVIEW) = struct
-  module type F =
-      functor (C : CORE with type V.usert = X.combined) ->
-        BARECODE with type state := C.V.state
-end
-
-module Weapon = struct type t end
-
-module type WEAPON_LIB = sig
-  type t = Weapon.t
-  module T : USERTYPE with type t = t
-  module Make :
-    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
-end
diff --git a/testlabl/fixedtypes.ml b/testlabl/fixedtypes.ml
deleted file mode 100644
index a7d7ca4a..00000000
--- a/testlabl/fixedtypes.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(* cvs update -r fixedtypes parsing typing *)
-
-(* recursive types *)
-class c = object (self) method m = 1 method s = self end
-module type S = sig type t = private #c end;;
-
-module M : S = struct type t = c end
-module type S' = S with type t = c;;
-
-class d = object inherit c method n = 2 end
-module type S2 = S with type t = private #d;;
-module M2 : S = struct type t = d end;;
-module M3 : S = struct type t = private #d end;;
-
-module T1 = struct
-  type ('a,'b) a = [`A of 'a | `B of 'b]
-  type ('a,'b) b = [`Z | ('a,'b) a]
-end
-module type T2 = sig
-  type a and b
-  val evala : a -> int
-  val evalb : b -> int
-end
-module type T3 = sig
-  type a0 = private [> (a0,b0) T1.a]
-  and b0 = private [> (a0,b0) T1.b]
-end
-module type T4 = sig
-  include T3
-  include T2 with type a = a0 and type b = b0
-end
-module F(X:T4) = struct
-  type a = X.a and b = X.b
-  let a = X.evala (`B `Z)
-  let b = X.evalb (`A(`B `Z))
-  let a2b (x : a) : b = `A x
-  let b2a (x : b) : a = `B x
-end
-module M4 = struct
-  type a = [`A of a | `B of b | `ZA]
-  and b = [`A of a | `B of b | `Z]
-  type a0 = a
-  type b0 = b
-  let rec eval0 = function
-      `A a -> evala a
-    | `B b -> evalb b
-  and evala : a -> int = function
-      #T1.a as x -> 1 + eval0 x
-    | `ZA -> 3
-  and evalb : b -> int = function
-      #T1.a as x -> 1 + eval0 x
-    | `Z -> 7
-end
-module M5 = F(M4)
-
-module M6 : sig
-  class ci : int ->
-    object
-      val x : int
-      method x : int
-      method move : int -> unit
-    end      
-  type c = private #ci
-  val create : int -> c
-end = struct
-  class ci x = object
-    val mutable x : int = x
-    method x = x
-    method move d = x <- x+d
-  end
-  type c = ci
-  let create = new ci
-end
-let f (x : M6.c) = x#move 3; x#x;;
-
-module M : sig type t = private [> `A of bool] end =
-  struct type t = [`A of int] end
diff --git a/testlabl/marshal_objects.diffs b/testlabl/marshal_objects.diffs
deleted file mode 100644
index bb9b4dd7..00000000
--- a/testlabl/marshal_objects.diffs
+++ /dev/null
@@ -1,800 +0,0 @@
-? bytecomp/alpha_eq.ml
-Index: bytecomp/lambda.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
-retrieving revision 1.44
-diff -u -r1.44 lambda.ml
---- bytecomp/lambda.ml	25 Aug 2005 15:35:16 -0000	1.44
-+++ bytecomp/lambda.ml	2 Feb 2006 05:08:56 -0000
-@@ -287,9 +287,10 @@
-     let compare = compare
-   end)
- 
--let free_ids get l =
-+let free_ids get used l =
-   let fv = ref IdentSet.empty in
-   let rec free l =
-+    let old = !fv in
-     iter free l;
-     fv := List.fold_right IdentSet.add (get l) !fv;
-     match l with
-@@ -307,17 +308,20 @@
-         fv := IdentSet.remove v !fv
-     | Lassign(id, e) ->
-         fv := IdentSet.add id !fv
-+    | Lifused(id, e) ->
-+        if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
-     | Lvar _ | Lconst _ | Lapply _
-     | Lprim _ | Lswitch _ | Lstaticraise _
-     | Lifthenelse _ | Lsequence _ | Lwhile _
--    | Lsend _ | Levent _ | Lifused _ -> ()
-+    | Lsend _ | Levent _ -> ()
-   in free l; !fv
- 
--let free_variables l =
--  free_ids (function Lvar id -> [id] | _ -> []) l
-+let free_variables ?(ifused=false) l =
-+  free_ids (function Lvar id -> [id] | _ -> []) ifused l
- 
- let free_methods l =
--  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
-+  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
-+    false l
- 
- (* Check if an action has a "when" guard *)
- let raise_count = ref 0
-Index: bytecomp/lambda.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
-retrieving revision 1.42
-diff -u -r1.42 lambda.mli
---- bytecomp/lambda.mli	25 Aug 2005 15:35:16 -0000	1.42
-+++ bytecomp/lambda.mli	2 Feb 2006 05:08:56 -0000
-@@ -177,7 +177,7 @@
- 
- val iter: (lambda -> unit) -> lambda -> unit
- module IdentSet: Set.S with type elt = Ident.t
--val free_variables: lambda -> IdentSet.t
-+val free_variables: ?ifused:bool -> lambda -> IdentSet.t
- val free_methods: lambda -> IdentSet.t
- 
- val transl_path: Path.t -> lambda
-Index: bytecomp/translclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
-retrieving revision 1.38
-diff -u -r1.38 translclass.ml
---- bytecomp/translclass.ml	13 Aug 2005 20:59:37 -0000	1.38
-+++ bytecomp/translclass.ml	2 Feb 2006 05:08:56 -0000
-@@ -46,6 +46,10 @@
- 
- let lfield v i = Lprim(Pfield i, [Lvar v])
- 
-+let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
-+
-+let lprim name args = Lapply(oo_prim name, args)
-+
- let transl_label l = share (Const_immstring l)
- 
- let rec transl_meth_list lst =
-@@ -68,8 +72,8 @@
-                                                     Lvar offset])])]))
- 
- let transl_val tbl create name =
--  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
--          [Lvar tbl; transl_label name])
-+  lprim (if create then "new_variable" else "get_variable")
-+    [Lvar tbl; transl_label name]
- 
- let transl_vals tbl create vals rem =
-   List.fold_right
-@@ -82,7 +86,7 @@
-     (fun (nm, id) rem ->
-        try
-          (nm, id,
--          Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
-+          lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
-          :: rem
-        with Not_found -> rem)
-     inh_meths []
-@@ -97,17 +101,15 @@
-   let (inh_init, obj_init, has_init) = init obj' in
-   if obj_init = lambda_unit then
-     (inh_init,
--     Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
--                      else"create_object_opt"),
--             [obj; Lvar cl]))
-+     lprim (if has_init then "create_object_and_run_initializers"
-+            else"create_object_opt")
-+       [obj; Lvar cl])
-   else begin
-    (inh_init,
--    Llet(Strict, obj',
--            Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
-+    Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
-          Lsequence(obj_init,
-                    if not has_init then Lvar obj' else
--                   Lapply (oo_prim "run_initializers_opt",
--			   [obj; Lvar obj'; Lvar cl]))))
-+                   lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
-   end
- 
- let rec build_object_init cl_table obj params inh_init obj_init cl =
-@@ -203,14 +205,13 @@
- 
- 
- let bind_method tbl lab id cl_init =
--  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
--                              [Lvar tbl; transl_label lab]),
-+  Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
-        cl_init)
- 
--let bind_methods tbl meths vals cl_init =
--  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
-+let bind_methods tbl methl vals cl_init =
-   let len = List.length methl and nvals = List.length vals in
--  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
-+  if len < 2 && nvals = 0 then
-+    List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
-   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
-   let ids = Ident.create "ids" in
-   let i = ref len in
-@@ -229,21 +230,19 @@
- 	       vals' cl_init)
-   in
-   Llet(StrictOpt, ids,
--       Lapply (oo_prim getter,
--               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-+       lprim getter
-+         ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-        List.fold_right
--         (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
-+         (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
-          methl cl_init)
- 
- let output_methods tbl methods lam =
-   match methods with
-     [] -> lam
-   | [lab; code] ->
--      lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
-+      lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
-   | _ ->
--      lsequence (Lapply(oo_prim "set_methods",
--                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
--        lam
-+      lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
- 
- let rec ignore_cstrs cl =
-   match cl.cl_desc with
-@@ -266,7 +265,8 @@
-            Llet (Strict, obj_init, 
-                  Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
- 			if top then [Lprim(Pfield 3, [lpath])] else []),
--                 bind_super cla super cl_init))
-+                 bind_super cla super cl_init),
-+           [], [])
-       | _ ->
-           assert false
-       end
-@@ -278,10 +278,11 @@
-             match field with
-               Cf_inher (cl, vals, meths) ->
-                 let cl_init = output_methods cla methods cl_init in
--                let inh_init, cl_init =
-+                let (inh_init, cl_init, meths', vals') =
-                   build_class_init cla false
-                     (vals, meths_super cla str.cl_meths meths)
-                     inh_init cl_init msubst top cl in
-+                let cl_init = bind_methods cla meths' vals' cl_init in
-                 (inh_init, cl_init, [], values)
-             | Cf_val (name, id, exp) ->
-                 (inh_init, cl_init, methods, (name, id)::values)
-@@ -304,29 +305,37 @@
-                 (inh_init, cl_init, methods, vals @ values)
-             | Cf_init exp ->
-                 (inh_init,
--                 Lsequence(Lapply (oo_prim "add_initializer",
--                                   Lvar cla :: msubst false (transl_exp exp)),
-+                 Lsequence(lprim "add_initializer"
-+                             (Lvar cla :: msubst false (transl_exp exp)),
-                            cl_init),
-                  methods, values))
-           str.cl_field
-           (inh_init, cl_init, [], [])
-       in
-       let cl_init = output_methods cla methods cl_init in
--      (inh_init, bind_methods cla str.cl_meths values cl_init)
-+      (* inh_init, bind_methods cla str.cl_meths values cl_init *)
-+      let methods =  Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
-+      (inh_init, cl_init, methods, values)
-   | Tclass_fun (pat, vals, cl, _) ->
--      let (inh_init, cl_init) =
-+      let (inh_init, cl_init, methods, values) =
-         build_class_init cla cstr super inh_init cl_init msubst top cl
-       in
-+      let fv = free_variables ~ifused:true cl_init in
-+      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
-       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
--      (inh_init, transl_vals cla true vals cl_init)
-+      (* inh_init, transl_vals cla true vals cl_init *)
-+      (inh_init, cl_init, methods, vals @ values)
-   | Tclass_apply (cl, exprs) ->
-       build_class_init cla cstr super inh_init cl_init msubst top cl
-   | Tclass_let (rec_flag, defs, vals, cl) ->
--      let (inh_init, cl_init) =
-+      let (inh_init, cl_init, methods, values) =
-         build_class_init cla cstr super inh_init cl_init msubst top cl
-       in
-+      let fv = free_variables ~ifused:true cl_init in
-+      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
-       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
--      (inh_init, transl_vals cla true vals cl_init)
-+      (* inh_init, transl_vals cla true vals cl_init *)
-+      (inh_init, cl_init, methods, vals @ values)
-   | Tclass_constraint (cl, vals, meths, concr_meths) ->
-       let virt_meths =
-         List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
-@@ -358,23 +367,34 @@
-               cl_init valids in
-           (inh_init,
-            Llet (Strict, inh, 
--		 Lapply(oo_prim "inherits", narrow_args @
--			[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-+		 lprim "inherits"
-+                   (narrow_args @
-+                    [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-                  Llet(StrictOpt, obj_init, lfield inh 0,
-                  Llet(Alias, inh_vals, lfield inh 1,
--                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
-+                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
-+          [], [])
-       | _ ->
- 	  let core cl_init =
-             build_class_init cla true super inh_init cl_init msubst top cl
- 	  in
- 	  if cstr then core cl_init else
--          let (inh_init, cl_init) =
--            core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
-+          let (inh_init, cl_init, methods, values) =
-+            core (Lsequence (lprim "widen" [Lvar cla], cl_init))
-           in
--          (inh_init,
--           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
-+          let cl_init = bind_methods cla methods values cl_init in
-+          (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
-       end
- 
-+let build_class_init cla env inh_init obj_init msubst top cl =
-+  let inh_init = List.rev inh_init in
-+  let (inh_init, cl_init, methods, values) =
-+    build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
-+  assert (inh_init = []);
-+  if IdentSet.mem env (free_variables ~ifused:true cl_init)
-+  then bind_methods cla methods (("", env) :: values) cl_init
-+  else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
-+
- let rec build_class_lets cl =
-   match cl.cl_desc with
-     Tclass_let (rec_flag, defs, vals, cl) ->
-@@ -459,16 +479,16 @@
-     Strict, new_init, lfunction [obj_init] obj_init',
-     Llet(
-     Alias, cla, transl_path path,
--    Lprim(Pmakeblock(0, Immutable),
--          [Lapply(Lvar new_init, [lfield cla 0]);
--           lfunction [table]
--             (Llet(Strict, env_init,
--                   Lapply(lfield cla 1, [Lvar table]),
--                   lfunction [envs]
--                     (Lapply(Lvar new_init,
--                             [Lapply(Lvar env_init, [Lvar envs])]))));
--           lfield cla 2;
--           lfield cla 3])))
-+    ltuple
-+      [Lapply(Lvar new_init, [lfield cla 0]);
-+       lfunction [table]
-+         (Llet(Strict, env_init,
-+               Lapply(lfield cla 1, [Lvar table]),
-+               lfunction [envs]
-+                 (Lapply(Lvar new_init,
-+                         [Lapply(Lvar env_init, [Lvar envs])]))));
-+       lfield cla 2;
-+       lfield cla 3]))
-   with Exit ->
-     lambda_unit
- 
-@@ -541,7 +561,7 @@
-   open CamlinternalOO
-   let builtin_meths arr self env env2 body =
-     let builtin, args = builtin_meths self env env2 body in
--    if not arr then [Lapply(oo_prim builtin, args)] else
-+    if not arr then [lprim builtin args] else
-     let tag = match builtin with
-       "get_const" -> GetConst
-     | "get_var"   -> GetVar
-@@ -599,7 +619,8 @@
- 
-   (* Prepare for heavy environment handling *)
-   let tables = Ident.create (Ident.name cl_id ^ "_tables") in
--  let (top_env, req) = oo_add_class tables in
-+  let table_init = ref None in
-+  let (top_env, req) = oo_add_class tables table_init in
-   let top = not req in
-   let cl_env, llets = build_class_lets cl in
-   let new_ids = if top then [] else Env.diff top_env cl_env in
-@@ -633,6 +654,7 @@
-         begin try
-           (* Doesn't seem to improve size for bytecode *)
-           (* if not !Clflags.native_code then raise Not_found; *)
-+          if !Clflags.debug then raise Not_found;
-           builtin_meths arr [self] env env2 (lfunction args body')
-         with Not_found ->
-           [lfunction (self :: args)
-@@ -665,15 +687,8 @@
-     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
--  in
--  assert (inh_init' = []);
--  let table = Ident.create "table"
--  and class_init = Ident.create (Ident.name cl_id ^ "_init")
--  and env_init = Ident.create "env_init"
--  and obj_init = Ident.create "obj_init" in
-+  let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
-+  let obj_init = Ident.create "obj_init" in
-   let pub_meths =
-     List.sort
-       (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
-@@ -685,42 +700,44 @@
-       let name' = List.assoc tag rev_map in
-       if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
-     tags pub_meths;
-+  let pos = cl.cl_loc.Location.loc_end in
-+  let filepos = [transl_label pos.Lexing.pos_fname;
-+                 Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
-   let ltable table lam =
--    Llet(Strict, table,
--         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
-+    Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam)
-   and ldirect obj_init =
-     Llet(Strict, obj_init, cl_init,
--         Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
-+         Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
-                    Lapply(Lvar obj_init, [lambda_unit])))
-   in
-   (* Simplest case: an object defined at toplevel (ids=[]) *)
-   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
- 
-+  let table = Ident.create "table"
-+  and class_init = Ident.create (Ident.name cl_id ^ "_init")
-+  and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
-+  let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
-   let concrete =
-     ids = [] ||
-     Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
--  and lclass lam =
--    let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
-+  and lclass cl_init lam =
-     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
-   and lbody fv =
-     if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
--      Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
--				    Lvar class_init])
-+      lprim "make_class"
-+        (transl_meth_list pub_meths :: Lvar class_init :: filepos)
-     else
-       ltable table (
-       Llet(
-       Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
--      Lsequence(
--      Lapply (oo_prim "init_class", [Lvar table]),
--      Lprim(Pmakeblock(0, Immutable),
--	    [Lapply(Lvar env_init, [lambda_unit]);
--	     Lvar class_init; Lvar env_init; lambda_unit]))))
-+      Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
-+                ltuple [Lapply(Lvar env_init, [lambda_unit]);
-+	                Lvar class_init; Lvar env_init; lambda_unit])))
-   and lbody_virt lenvs =
--    Lprim(Pmakeblock(0, Immutable),
--          [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
-+    ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
-   in
-   (* Still easy: a class defined at toplevel *)
--  if top && concrete then lclass lbody else
-+  if top && concrete then lclass (llets cl_init_fun) lbody else
-   if top then llets (lbody_virt lambda_unit) else
- 
-   (* Now for the hard stuff: prepare for table cacheing *)
-@@ -733,23 +750,16 @@
-   let lenv =
-     let menv =
-       if !new_ids_meths = [] then lambda_unit else
--      Lprim(Pmakeblock(0, Immutable),
--            List.map (fun id -> Lvar id) !new_ids_meths) in
-+      ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
-     if !new_ids_init = [] then menv else
--    Lprim(Pmakeblock(0, Immutable),
--          menv :: List.map (fun id -> Lvar id) !new_ids_init)
-+    ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init)
-   and linh_envs =
-     List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
-       (List.rev inh_init)
-   in
-   let make_envs lam =
-     Llet(StrictOpt, envs,
--         (if linh_envs = [] then lenv else
--         Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
--         lam)
--  and def_ids cla lam =
--    Llet(StrictOpt, env2,
--         Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
-+         (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
-          lam)
-   in
-   let inh_paths =
-@@ -757,46 +767,53 @@
-       (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
-   let inh_keys =
-     List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
--  let lclass lam =
--    Llet(Strict, class_init,
--         Lfunction(Curried, [cla], def_ids cla cl_init), lam)
-+  let lclass_init lam =
-+    Llet(Strict, class_init, cl_init_fun, lam)
-   and lcache lam =
-     if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
--    Llet(Strict, cached,
--         Lapply(oo_prim "lookup_tables",
--                [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
-+    Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys],
-          lam)
-   and lset cached i lam =
-     Lprim(Psetfield(i, true), [Lvar cached; lam])
-   in
--  let ldirect () =
--    ltable cla
--      (Llet(Strict, env_init, def_ids cla cl_init,
--            Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
--                      lset cached 0 (Lvar env_init))))
--  and lclass_virt () =
--    lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
-+  let ldirect prim pos =
-+    ltable cla (
-+    Llet(Strict, env_init, cl_init,
-+         Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
-+  and lclass_concrete cached =
-+    ltuple [Lapply (lfield cached 0, [lenvs]);
-+            lfield cached 1; lfield cached 0; lenvs]
-   in
-+
-   llets (
--  lcache (
--  Lsequence(
--  Lifthenelse(lfield cached 0, lambda_unit,
--              if ids = [] then ldirect () else
--              if not concrete then lclass_virt () else
--              lclass (
--              Lapply (oo_prim "make_class_store",
--                      [transl_meth_list pub_meths;
--                       Lvar class_init; Lvar cached]))),
-   make_envs (
--  if ids = [] then Lapply(lfield cached 0, [lenvs]) else
--  Lprim(Pmakeblock(0, Immutable),
--        if concrete then
--          [Lapply(lfield cached 0, [lenvs]);
--           lfield cached 1;
--           lfield cached 0;
--           lenvs]
--        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
--       )))))
-+  if inh_paths = [] && concrete then
-+    if ids = [] then begin
-+      table_init := Some (ldirect "init_class_shared" filepos);
-+      Lapply (Lvar tables, [lenvs])
-+    end else begin
-+      let init =
-+        lclass cl_init_fun (fun _ ->
-+          lprim "make_class_env"
-+            (transl_meth_list pub_meths :: Lvar class_init :: filepos))
-+      in table_init := Some init;
-+      lclass_concrete tables
-+    end
-+  else begin
-+    lcache (
-+    Lsequence(
-+    Lifthenelse(lfield cached 0, lambda_unit,
-+                if ids = [] then lset cached 0 (ldirect "init_class" []) else
-+                if not concrete then lset cached 0 cl_init_fun else
-+                lclass_init (
-+                lprim "make_class_store"
-+                  [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
-+    llets (
-+    make_envs (
-+    if ids = [] then Lapply(lfield cached 0, [lenvs]) else
-+    if concrete then lclass_concrete cached else
-+    ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
-+  end))
- 
- (* Wrapper for class compilation *)
- 
-Index: bytecomp/translobj.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
-retrieving revision 1.9
-diff -u -r1.9 translobj.ml
---- bytecomp/translobj.ml	26 May 2004 11:10:51 -0000	1.9
-+++ bytecomp/translobj.ml	2 Feb 2006 05:08:56 -0000
-@@ -88,7 +88,6 @@
- 
- (* Insert labels *)
- 
--let string s = Lconst (Const_base (Const_string s))
- let int n = Lconst (Const_base (Const_int n))
- 
- let prim_makearray =
-@@ -124,8 +123,8 @@
- let top_env = ref Env.empty
- let classes = ref []
- 
--let oo_add_class id =
--  classes := id :: !classes;
-+let oo_add_class id init =
-+  classes := (id, init) :: !classes;
-   (!top_env, !cache_required)
- 
- let oo_wrap env req f x =
-@@ -141,10 +140,12 @@
-     let lambda = f x in
-     let lambda =
-       List.fold_left
--        (fun lambda id ->
-+        (fun lambda (id, init) ->
-           Llet(StrictOpt, id,
--               Lprim(Pmakeblock(0, Mutable),
--                     [lambda_unit; lambda_unit; lambda_unit]),
-+               (match !init with
-+                 Some lam -> lam
-+               | None -> Lprim(Pmakeblock(0, Mutable),
-+                               [lambda_unit; lambda_unit; lambda_unit])),
-                lambda))
-         lambda !classes
-     in
-Index: bytecomp/translobj.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
-retrieving revision 1.6
-diff -u -r1.6 translobj.mli
---- bytecomp/translobj.mli	26 May 2004 11:10:51 -0000	1.6
-+++ bytecomp/translobj.mli	2 Feb 2006 05:08:56 -0000
-@@ -25,4 +25,4 @@
-     Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
- 
- val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
--val oo_add_class: Ident.t -> Env.t * bool
-+val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
-Index: byterun/compare.h
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
-retrieving revision 1.2
-diff -u -r1.2 compare.h
---- byterun/compare.h	31 Dec 2003 14:20:35 -0000	1.2
-+++ byterun/compare.h	2 Feb 2006 05:08:56 -0000
-@@ -17,5 +17,6 @@
- #define CAML_COMPARE_H
- 
- CAMLextern int caml_compare_unordered;
-+CAMLextern value caml_compare(value, value);
- 
- #endif /* CAML_COMPARE_H */
-Index: byterun/extern.c
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
-retrieving revision 1.59
-diff -u -r1.59 extern.c
---- byterun/extern.c	4 Jan 2006 16:55:49 -0000	1.59
-+++ byterun/extern.c	2 Feb 2006 05:08:56 -0000
-@@ -411,6 +411,22 @@
-       extern_record_location(v);
-       break;
-     }
-+    case Object_tag: {
-+      value field0;
-+      mlsize_t i;
-+      i = Wosize_val(Field(v, 0)) - 1;
-+      field0 = Field(Field(v, 0),i);
-+      if (Wosize_val(field0) > 0) {
-+        writecode32(CODE_OBJECT, Wosize_hd (hd));
-+        extern_record_location(v);
-+        extern_rec(field0);
-+        for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
-+        v = Field(v, i);
-+        goto tailcall;
-+      }
-+      if (!extern_closures)
-+        extern_invalid_argument("output_value: dynamic class");
-+    } /* may fall through */
-     default: {
-       value field0;
-       mlsize_t i;
-Index: byterun/intern.c
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
-retrieving revision 1.60
-diff -u -r1.60 intern.c
---- byterun/intern.c	22 Sep 2005 14:21:50 -0000	1.60
-+++ byterun/intern.c	2 Feb 2006 05:08:56 -0000
-@@ -28,6 +28,8 @@
- #include "mlvalues.h"
- #include "misc.h"
- #include "reverse.h"
-+#include "callback.h"
-+#include "compare.h"
- 
- static unsigned char * intern_src;
- /* Reading pointer in block holding input data. */
-@@ -98,6 +100,25 @@
- #define readblock(dest,len) \
-   (memmove((dest), intern_src, (len)), intern_src += (len))
- 
-+static value get_method_table (value key)
-+{
-+  static value *classes = NULL;
-+  value current;
-+  if (classes == NULL) {
-+    classes = caml_named_value("caml_oo_classes");
-+    if (classes == NULL) return 0;
-+    caml_register_global_root(classes);
-+  }
-+  for (current = Field(*classes, 0); Is_block(current);
-+       current = Field(current, 1))
-+  {
-+    value head = Field(current, 0);
-+    if (caml_compare(key, Field(head, 0)) == Val_int(0))
-+      return Field(head, 1);
-+  }
-+  return 0;
-+}
-+
- static void intern_cleanup(void)
- {
-   if (intern_input_malloced) caml_stat_free(intern_input);
-@@ -315,6 +336,24 @@
-         Custom_ops_val(v) = ops;
-         intern_dest += 1 + size;
-         break;
-+      case CODE_OBJECT:
-+        size = read32u();
-+        v = Val_hp(intern_dest);
-+        *dest = v;
-+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-+        dest = (value *) (intern_dest + 1);
-+        *intern_dest = Make_header(size, Object_tag, intern_color);
-+        intern_dest += 1 + size;
-+        intern_rec(dest);
-+        *dest = get_method_table(*dest);
-+        if (*dest == 0) {
-+          intern_cleanup();
-+          caml_failwith("input_value: unknown class");
-+        }
-+        for(size--, dest++; size > 1; size--, dest++)
-+          intern_rec(dest);
-+        goto tailcall;
-+        
-       default:
-         intern_cleanup();
-         caml_failwith("input_value: ill-formed message");
-Index: byterun/intext.h
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
-retrieving revision 1.32
-diff -u -r1.32 intext.h
---- byterun/intext.h	22 Sep 2005 14:21:50 -0000	1.32
-+++ byterun/intext.h	2 Feb 2006 05:08:56 -0000
-@@ -56,6 +56,7 @@
- #define CODE_CODEPOINTER 0x10
- #define CODE_INFIXPOINTER 0x11
- #define CODE_CUSTOM 0x12
-+#define CODE_OBJECT 0x14
- 
- #if ARCH_FLOAT_ENDIANNESS == 0x76543210
- #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
-Index: stdlib/camlinternalOO.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
-retrieving revision 1.14
-diff -u -r1.14 camlinternalOO.ml
---- stdlib/camlinternalOO.ml	25 Oct 2005 18:34:07 -0000	1.14
-+++ stdlib/camlinternalOO.ml	2 Feb 2006 05:08:56 -0000
-@@ -305,10 +305,38 @@
-     public_methods;
-   table
- 
-+(*
-+let create_table_variables pub_meths priv_meths vars =
-+  let tbl = create_table pub_meths in
-+  let pub_meths = to_array pub_meths
-+  and priv_meths = to_array priv_meths
-+  and vars = to_array vars in
-+  let len = 2 + Array.length pub_meths + Array.length priv_meths in
-+  let res = Array.create len tbl in
-+  let mv = new_methods_variables tbl pub_meths vars in
-+  Array.blit mv 0 res 1;
-+  res
-+*)
-+
- let init_class table =
-   inst_var_count := !inst_var_count + table.size - 1;
-   table.initializers <- List.rev table.initializers;
--  resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
-+  let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
-+  (* keep 1 more for extra info *)
-+  let len = if len > Array.length table.methods then len else len+1 in
-+  resize table len
-+
-+let classes = ref []
-+let () = Callback.register "caml_oo_classes" classes
-+
-+let init_class_shared table (file : string) (pos : int) =
-+  init_class table;
-+  let rec unique_pos pos =
-+    if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
-+    else pos in
-+  let pos = unique_pos pos in
-+  table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
-+  classes := ((file, pos), table.methods) :: !classes
- 
- let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
-   narrow cla vals virt_meths concr_meths;
-@@ -319,12 +347,18 @@
-    Array.map (fun nm -> get_method cla (get_method_label cla nm))
-      (to_array concr_meths))
- 
--let make_class pub_meths class_init =
-+let make_class pub_meths class_init file pos =
-   let table = create_table pub_meths in
-   let env_init = class_init table in
--  init_class table;
-+  init_class_shared table file pos;
-   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
- 
-+let make_class_env pub_meths class_init file pos =
-+  let table = create_table pub_meths in
-+  let env_init = class_init table in
-+  init_class_shared table file pos;
-+  (env_init, class_init)
-+
- type init_table = { mutable env_init: t; mutable class_init: table -> t }
- 
- let make_class_store pub_meths class_init init_table =
-Index: stdlib/camlinternalOO.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
-retrieving revision 1.9
-diff -u -r1.9 camlinternalOO.mli
---- stdlib/camlinternalOO.mli	25 Oct 2005 18:34:07 -0000	1.9
-+++ stdlib/camlinternalOO.mli	2 Feb 2006 05:08:56 -0000
-@@ -43,14 +43,20 @@
- val add_initializer : table -> (obj -> unit) -> unit
- val dummy_table : table
- val create_table : string array -> table
-+(* val create_table_variables :
-+    string array -> string array -> string array -> table *)
- val init_class : table -> unit
-+val init_class_shared : table -> string -> int -> unit
- val inherits :
-     table -> string array -> string array -> string array ->
-     (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
-     (Obj.t * int array * closure array)
- val make_class :
--    string array -> (table -> Obj.t -> t) ->
-+    string array -> (table -> Obj.t -> t) -> string -> int ->
-     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
-+val make_class_env :
-+    string array -> (table -> Obj.t -> t) -> string -> int ->
-+    (Obj.t -> t) * (table -> Obj.t -> t)
- type init_table
- val make_class_store :
-     string array -> (table -> t) -> init_table -> unit
diff --git a/testlabl/multimatch.diffs b/testlabl/multimatch.diffs
deleted file mode 100644
index 6eb34b72..00000000
--- a/testlabl/multimatch.diffs
+++ /dev/null
@@ -1,1418 +0,0 @@
-Index: parsing/lexer.mll
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v
-retrieving revision 1.73
-diff -u -r1.73 lexer.mll
---- parsing/lexer.mll	11 Apr 2005 16:44:26 -0000	1.73
-+++ parsing/lexer.mll	2 Feb 2006 06:28:32 -0000
-@@ -63,6 +63,8 @@
-     "match", MATCH;
-     "method", METHOD;
-     "module", MODULE;
-+    "multifun", MULTIFUN;
-+    "multimatch", MULTIMATCH;
-     "mutable", MUTABLE;
-     "new", NEW;
-     "object", OBJECT;
-Index: parsing/parser.mly
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
-retrieving revision 1.123
-diff -u -r1.123 parser.mly
---- parsing/parser.mly	23 Mar 2005 03:08:37 -0000	1.123
-+++ parsing/parser.mly	2 Feb 2006 06:28:32 -0000
-@@ -257,6 +257,8 @@
- %token MINUSDOT
- %token MINUSGREATER
- %token MODULE
-+%token MULTIFUN
-+%token MULTIMATCH
- %token MUTABLE
- %token  NATIVEINT
- %token NEW
-@@ -325,7 +327,7 @@
- %nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
- %nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
- %nonassoc below_WITH
--%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
-+%nonassoc FUNCTION WITH MULTIFUN        /* below BAR  (match ... with ...) */
- %nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
- %nonassoc THEN                          /* below ELSE (if ... then ...) */
- %nonassoc ELSE                          /* (if ... then ... else ...) */
-@@ -804,8 +806,12 @@
-       { mkexp(Pexp_function("", None, List.rev $3)) }
-   | FUN labeled_simple_pattern fun_def
-       { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
-+  | MULTIFUN opt_bar match_cases
-+      { mkexp(Pexp_multifun(List.rev $3)) }
-   | MATCH seq_expr WITH opt_bar match_cases
--      { mkexp(Pexp_match($2, List.rev $5)) }
-+      { mkexp(Pexp_match($2, List.rev $5, false)) }
-+  | MULTIMATCH seq_expr WITH opt_bar match_cases
-+      { mkexp(Pexp_match($2, List.rev $5, true)) }
-   | TRY seq_expr WITH opt_bar match_cases
-       { mkexp(Pexp_try($2, List.rev $5)) }
-   | TRY seq_expr WITH error
-@@ -1318,10 +1324,10 @@
-   | simple_core_type2                           { Rinherit $1 }
- ;
- tag_field:
--    name_tag OF opt_ampersand amper_type_list
--      { Rtag ($1, $3, List.rev $4) }
--  | name_tag
--      { Rtag ($1, true, []) }
-+    name_tag OF opt_ampersand amper_type_list amper_type_pair_list
-+      { Rtag ($1, $3, List.rev $4, $5) }
-+  | name_tag amper_type_pair_list
-+      { Rtag ($1, true, [], $2) }
- ;
- opt_ampersand:
-     AMPERSAND                                   { true }
-@@ -1331,6 +1337,11 @@
-     core_type                                   { [$1] }
-   | amper_type_list AMPERSAND core_type         { $3 :: $1 }
- ;
-+amper_type_pair_list:
-+    AMPERSAND core_type EQUAL core_type amper_type_pair_list
-+      { ($2, $4) :: $5 }
-+  | /* empty */
-+      { [] }
- opt_present:
-     LBRACKETGREATER name_tag_list RBRACKET      { List.rev $2 }
-   | /* empty */                                 { [] }
-Index: parsing/parsetree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
-retrieving revision 1.42
-diff -u -r1.42 parsetree.mli
---- parsing/parsetree.mli	23 Mar 2005 03:08:37 -0000	1.42
-+++ parsing/parsetree.mli	2 Feb 2006 06:28:32 -0000
-@@ -43,7 +43,7 @@
-   | Pfield_var
- 
- and row_field =
--    Rtag of label * bool * core_type list
-+    Rtag of label * bool * core_type list * (core_type * core_type) list
-   | Rinherit of core_type
- 
- (* XXX Type expressions for the class language *)
-@@ -86,7 +86,7 @@
-   | 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_match of expression * (pattern * expression) list * bool
-   | Pexp_try of expression * (pattern * expression) list
-   | Pexp_tuple of expression list
-   | Pexp_construct of Longident.t * expression option * bool
-@@ -111,6 +111,7 @@
-   | Pexp_lazy of expression
-   | Pexp_poly of expression * core_type option
-   | Pexp_object of class_structure
-+  | Pexp_multifun of (pattern * expression) list
- 
- (* Value descriptions *)
- 
-Index: parsing/printast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
-retrieving revision 1.29
-diff -u -r1.29 printast.ml
---- parsing/printast.ml	4 Jan 2006 16:55:50 -0000	1.29
-+++ parsing/printast.ml	2 Feb 2006 06:28:32 -0000
-@@ -205,10 +205,14 @@
-       line i ppf "Pexp_apply\n";
-       expression i ppf e;
-       list i label_x_expression ppf l;
--  | Pexp_match (e, l) ->
-+  | Pexp_match (e, l, b) ->
-       line i ppf "Pexp_match\n";
-       expression i ppf e;
-       list i pattern_x_expression_case ppf l;
-+      bool i ppf b
-+  | Pexp_multifun l ->
-+      line i ppf "Pexp_multifun\n";
-+      list i pattern_x_expression_case ppf l;
-   | Pexp_try (e, l) ->
-       line i ppf "Pexp_try\n";
-       expression i ppf e;
-@@ -653,7 +657,7 @@
- 
- and label_x_bool_x_core_type_list i ppf x =
-   match x with
--    Rtag (l, b, ctl) ->
-+    Rtag (l, b, ctl, cstr) ->
-       line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
-       list (i+1) core_type ppf ctl
-   | Rinherit (ct) ->
-Index: typing/btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.38
-diff -u -r1.38 btype.ml
---- typing/btype.ml	4 Jan 2006 16:55:50 -0000	1.38
-+++ typing/btype.ml	2 Feb 2006 06:28:32 -0000
-@@ -66,16 +66,16 @@
-     Clink r when !r <> Cunknown -> commu_repr !r
-   | c -> c
- 
--let rec row_field_repr_aux tl = function
--    Reither(_, tl', _, {contents = Some fi}) ->
--      row_field_repr_aux (tl@tl') fi
--  | Reither(c, tl', m, r) ->
--      Reither(c, tl@tl', m, r)
-+let rec row_field_repr_aux tl tl2 = function
-+    Reither(_, tl', _, tl2', {contents = Some fi}) ->
-+      row_field_repr_aux (tl@tl') (tl2@tl2') fi
-+  | Reither(c, tl', m, tl2', r) ->
-+      Reither(c, tl@tl', m, tl2@tl2', r)
-   | Rpresent (Some _) when tl <> [] ->
-       Rpresent (Some (List.hd tl))
-   | fi -> fi
- 
--let row_field_repr fi = row_field_repr_aux [] fi
-+let row_field_repr fi = row_field_repr_aux [] [] fi
- 
- let rec rev_concat l ll =
-   match ll with
-@@ -170,7 +170,8 @@
-     (fun (_, fi) ->
-       match row_field_repr fi with
-       | Rpresent(Some ty) -> f ty
--      | Reither(_, tl, _, _) -> List.iter f tl
-+      | Reither(_, tl, _, tl2, _) ->
-+          List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2
-       | _ -> ())
-     row.row_fields;
-   match (repr row.row_more).desc with
-@@ -208,15 +209,17 @@
-       (fun (l, fi) -> l,
-         match row_field_repr fi with
-         | Rpresent(Some ty) -> Rpresent(Some(f ty))
--        | Reither(c, tl, m, e) ->
-+        | Reither(c, tl, m, tpl, e) ->
-             let e = if keep then e else ref None in
-             let m = if row.row_fixed then fixed else m in
-             let tl = List.map f tl in
-+            let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl
-+            and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in
-             bound := List.filter
-                 (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
--                (List.map repr tl)
-+                (List.map repr tl @ tl1 @ tl2)
-               @ !bound;
--            Reither(c, tl, m, e)
-+            Reither(c, tl, m, List.combine tl1 tl2, e)
-         | _ -> fi)
-       row.row_fields in
-   let name =
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.200
-diff -u -r1.200 ctype.ml
---- typing/ctype.ml	6 Jan 2006 02:16:24 -0000	1.200
-+++ typing/ctype.ml	2 Feb 2006 06:28:32 -0000
-@@ -340,7 +340,7 @@
-       let fi = filter_row_fields erase fi in
-       match row_field_repr f with
-         Rabsent -> fi
--      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
-+      | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi
-       | _ -> p :: fi
- 
-                     (**************************************)
-@@ -1286,6 +1286,10 @@
- 
- module TypeMap = Map.Make (TypeOps)
- 
-+
-+(* A list of univars which may appear free in a type, but only if generic *)
-+let allowed_univars = ref TypeSet.empty
-+
- (* Test the occurence of free univars in a type *)
- (* that's way too expansive. Must do some kind of cacheing *)
- let occur_univar env ty =
-@@ -1307,7 +1311,12 @@
-     then
-       match ty.desc with
-         Tunivar ->
--          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
-+          if TypeSet.mem ty bound then () else
-+          if TypeSet.mem ty !allowed_univars &&
-+            (ty.level = generic_level ||
-+             ty.level = pivot_level - generic_level)
-+          then ()
-+          else raise (Unify [ty, newgenvar()])
-       | Tpoly (ty, tyl) ->
-           let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
-           occur_rec bound  ty
-@@ -1393,6 +1402,7 @@
-   with exn -> univar_pairs := old_univars; raise exn
- 
- let univar_pairs = ref []
-+let delayed_conditionals = ref []
- 
- 
-                               (*****************)
-@@ -1691,9 +1701,11 @@
-               with Not_found -> (h,l)::hl)
-             (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
-             (List.map fst r2));
-+  let fixed1 = row1.row_fixed || rm1.desc <> Tvar
-+  and fixed2 = row2.row_fixed || rm2.desc <> Tvar in
-   let more =
--    if row1.row_fixed then rm1 else
--    if row2.row_fixed then rm2 else
-+    if fixed1 then rm1 else
-+    if fixed2 then rm2 else
-     newgenvar ()
-   in update_level env (min rm1.level rm2.level) more;
-   let fixed = row1.row_fixed || row2.row_fixed
-@@ -1726,18 +1738,18 @@
-   let bound = row1.row_bound @ row2.row_bound in
-   let row0 = {row_fields = []; row_more = more; row_bound = bound;
-               row_closed = closed; row_fixed = fixed; row_name = name} in
--  let set_more row rest =
-+  let set_more row row_fixed rest =
-     let rest =
-       if closed then
-         filter_row_fields row.row_closed rest
-       else rest in
--    if rest <> [] && (row.row_closed || row.row_fixed)
--    || closed && row.row_fixed && not row.row_closed then begin
-+    if rest <> [] && (row.row_closed || row_fixed)
-+    || closed && row_fixed && not row.row_closed then begin
-       let t1 = mkvariant [] true and t2 = mkvariant rest false in
-       raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
-     end;
-     let rm = row_more row in
--    if row.row_fixed then
-+    if row_fixed then
-       if row0.row_more == rm then () else
-       if rm.desc = Tvar then link_type rm row0.row_more else
-       unify env rm row0.row_more
-@@ -1748,11 +1760,11 @@
-   in
-   let md1 = rm1.desc and md2 = rm2.desc in
-   begin try
--    set_more row1 r2;
--    set_more row2 r1;
-+    set_more row1 fixed1 r2;
-+    set_more row2 fixed2 r1;
-     List.iter
-       (fun (l,f1,f2) ->
--        try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2
-+        try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2
-         with Unify trace ->
-           raise (Unify ((mkvariant [l,f1] true,
-                          mkvariant [l,f2] true) :: trace)))
-@@ -1761,13 +1773,13 @@
-     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
-   end
- 
--and unify_row_field env fixed1 fixed2 l f1 f2 =
-+and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 =
-   let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
-   if f1 == f2 then () else
-   match f1, f2 with
-     Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
-   | Rpresent None, Rpresent None -> ()
--  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
-+  | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) ->
-       if e1 == e2 then () else
-       let redo =
-         (m1 || m2) &&
-@@ -1777,32 +1789,70 @@
-             List.iter (unify env t1) tl;
-             !e1 <> None || !e2 <> None
-         end in
--      if redo then unify_row_field env fixed1 fixed2 l f1 f2 else
-+      let redo =
-+        redo || begin
-+          if tp1 = [] && fixed1 then unify_pairs env tp2;
-+          if tp2 = [] && fixed2 then unify_pairs env tp1;
-+          !e1 <> None || !e2 <> None
-+        end
-+      in
-+      if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else
-       let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
-       let rec remq tl = function [] -> []
-         | ty :: tl' ->
-             if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
-       in
-       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
-+      let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in
-+      let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in
-+      let rec rempq tp = function [] -> []
-+        | (t1,t2 as p) :: tp' ->
-+            if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then
-+              rempq tp tp'
-+            else p :: rempq tp tp'
-+      in
-+      let tp1' =
-+        if fixed2 then begin
-+          delayed_conditionals :=
-+            (!univar_pairs, tp1, l, row2) :: !delayed_conditionals;
-+          []
-+        end else rempq tp2 tp1
-+      and tp2' =
-+        if fixed1 then begin
-+          delayed_conditionals :=
-+            (!univar_pairs, tp2, l, row1) :: !delayed_conditionals;
-+          []
-+        end else rempq tp1 tp2
-+      in
-       let e = ref None in
--      let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
--      and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
--      set_row_field e1 f1'; set_row_field e2 f2';
--  | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
--  | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
-+      let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e)
-+      and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in
-+      set_row_field e1 f1'; set_row_field e2 f2'
-+  | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2
-+  | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1
-   | Rabsent, Rabsent -> ()
--  | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
-+  | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 ->
-       set_row_field e1 f2;
--      (try List.iter (fun t1 -> unify env t1 t2) tl
-+      begin try
-+        List.iter (fun t1 -> unify env t1 t2) tl;
-+        List.iter (fun (t1,t2) -> unify env t1 t2) tp
-+      with exn -> e1 := None; raise exn
-+      end
-+  | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 ->
-+      set_row_field e2 f1;
-+      begin try
-+        List.iter (unify env t1) tl;
-+        List.iter (fun (t1,t2) -> unify env t1 t2) tp
-+      with exn -> e2 := None; raise exn
-+      end
-+  | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 ->
-+      set_row_field e1 f2;
-+      (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
-       with exn -> e1 := None; raise exn)
--  | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
-+  | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 ->
-       set_row_field e2 f1;
--      (try List.iter (unify env t1) tl
-+      (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
-       with exn -> e2 := None; raise exn)
--  | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
--      set_row_field e1 f2
--  | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
--      set_row_field e2 f1
-   | _ -> raise (Unify [])
-     
- 
-@@ -1920,6 +1970,166 @@
-                         (*  Matching between type schemes  *)
-                         (***********************************)
- 
-+(* Forward declaration (order should be reversed...) *)
-+let equal' = ref (fun _ -> failwith "Ctype.equal'")
-+
-+let make_generics_univars tyl =
-+  let polyvars = ref TypeSet.empty in
-+  let rec make_rec ty =
-+    let ty = repr ty in
-+    if ty.level = generic_level then begin
-+      if ty.desc = Tvar  then begin
-+        log_type ty;
-+        ty.desc <- Tunivar;
-+        polyvars := TypeSet.add ty !polyvars
-+      end
-+      else if ty.desc = Tunivar then set_level ty (generic_level - 1);
-+      ty.level <- pivot_level - generic_level;
-+      iter_type_expr make_rec ty
-+    end
-+  in
-+  List.iter make_rec tyl;
-+  List.iter unmark_type tyl;
-+  !polyvars
-+
-+(* New version of moregeneral, using unification *)
-+
-+let copy_cond (p,tpl,l,row) =
-+  let row =
-+    match repr (copy (newgenty (Tvariant row))) with
-+      {desc=Tvariant row} -> row
-+    | _ -> assert false
-+  and pairs =
-+    List.map (fun (t1,t2) -> copy t1, copy t2) tpl in
-+  (p, pairs, l, row)
-+
-+let get_row_field l row =
-+  try row_field_repr (List.assoc l (row_repr row).row_fields)
-+  with Not_found -> Rabsent
-+
-+let rec check_conditional_list env cdtls pattvars tpls =
-+  match cdtls with
-+    [] ->
-+      let finished =
-+        List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in
-+      if not finished then begin
-+        let polyvars = make_generics_univars pattvars in
-+        delayed_conditionals := [];
-+        allowed_univars := polyvars;
-+        List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs)
-+          tpls;
-+        check_conditionals env polyvars !delayed_conditionals
-+      end
-+  | (pairs, tpl1, l, row2 as cond) :: cdtls ->
-+      let cont = check_conditional_list env cdtls pattvars in
-+      let tpl1 =
-+        List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
-+      let included =
-+        List.for_all
-+          (fun (t1,t2) ->
-+            List.exists
-+              (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
-+              tpls)
-+          tpl1 in
-+      if included then cont tpls else
-+      match get_row_field l row2 with
-+        Rpresent _ ->
-+          cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
-+      | Rabsent -> cont tpls
-+      | Reither (c, tl2, _, _, _) ->
-+          cont tpls;
-+          if c && tl2 <> [] then () (* cannot succeed *) else
-+          let (pairs, tpl1, l, row2) = copy_cond cond
-+          and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls
-+          and pattvars = List.map copy pattvars
-+          and cdtls = List.map copy_cond cdtls in
-+          cleanup_types ();
-+          let tl2, tpl2, e2 =
-+            match get_row_field l row2 with
-+              Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2
-+            | _ -> assert false
-+          in
-+          let snap = Btype.snapshot () in
-+          let ok =
-+            try
-+              begin match tl2 with
-+                [] ->
-+                  set_row_field e2 (Rpresent None)
-+              | t::tl ->
-+                  set_row_field e2 (Rpresent (Some t));
-+                  List.iter (unify env t) tl
-+              end;
-+              List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
-+              true
-+            with exn ->
-+              Btype.backtrack snap;
-+              false
-+          in
-+            (* This is not [cont] : types have been copied *)
-+          if ok then
-+            check_conditional_list env cdtls pattvars
-+              (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
-+
-+and check_conditionals env polyvars cdtls =
-+  let cdtls = List.map copy_cond cdtls in
-+  let pattvars = ref [] in
-+  TypeSet.iter
-+    (fun ty ->
-+      let ty = repr ty in
-+      match ty.desc with
-+        Tsubst ty ->
-+          let ty = repr ty in
-+          begin match ty.desc with
-+            Tunivar ->
-+              log_type ty;
-+              ty.desc <- Tvar;
-+              pattvars := ty :: !pattvars
-+          | Ttuple [tv;_] ->
-+              if tv.desc = Tunivar then
-+                (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars)
-+              else if tv.desc <> Tvar then assert false
-+          | Tvar -> ()
-+          | _ -> assert false
-+          end
-+      | _ -> ())
-+    polyvars;
-+  cleanup_types ();
-+  check_conditional_list env cdtls !pattvars []
-+  
-+
-+(* Must empty univar_pairs first *)
-+let unify_poly env polyvars subj patt =
-+  let old_level = !current_level in
-+  current_level := generic_level;
-+  delayed_conditionals := [];
-+  allowed_univars := polyvars;
-+  try
-+    unify env subj patt;
-+    check_conditionals env polyvars !delayed_conditionals;
-+    current_level := old_level;
-+    allowed_univars := TypeSet.empty;
-+    delayed_conditionals := []
-+  with exn ->
-+    current_level := old_level;
-+    allowed_univars := TypeSet.empty;
-+    delayed_conditionals := [];
-+    raise exn
-+
-+let moregeneral env _ subj patt =
-+  let old_level = !current_level in
-+  current_level := generic_level;
-+  let subj = instance subj
-+  and patt = instance patt in
-+  let polyvars = make_generics_univars [patt] in
-+  current_level := old_level;
-+  let snap = Btype.snapshot () in
-+  try
-+    unify_poly env polyvars subj patt;
-+    true
-+  with Unify _ ->
-+    Btype.backtrack snap;
-+    false
-+
- (*
-    Update the level of [ty]. First check that the levels of generic
-    variables from the subject are not lowered.
-@@ -2072,35 +2282,101 @@
-         Rpresent(Some t1), Rpresent(Some t2) ->
-           moregen inst_nongen type_pairs env t1 t2
-       | Rpresent None, Rpresent None -> ()
--      | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ ->
-+      | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ ->
-           set_row_field e1 f2;
-           List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
--      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
-+      | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) ->
-           if e1 != e2 then begin
-             if c1 && not c2 then raise(Unify []);
--            set_row_field e1 (Reither (c2, [], m2, e2));
--            if List.length tl1 = List.length tl2 then
--              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
--            else match tl2 with
--              t2 :: _ ->
-+            let tpl' = if tpl1 = [] then tpl2 else [] in
-+            set_row_field e1 (Reither (c2, [], m2, tpl', e2));
-+            begin match tl2 with
-+              [t2] ->
-                 List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
-                   tl1
--            | [] ->
--                if tl1 <> [] then raise (Unify [])
-+            | _ ->
-+                if List.length tl1 <> List.length tl2 then raise (Unify []);
-+                List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
-+            end;
-+            if tpl1 <> [] then
-+              delayed_conditionals :=
-+                (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals
-           end
--      | Reither(true, [], _, e1), Rpresent None when not univ ->
-+      | Reither(true, [], _, [], e1), Rpresent None when not univ ->
-           set_row_field e1 f2
--      | Reither(_, _, _, e1), Rabsent when not univ ->
-+      | Reither(_, _, _, [], e1), Rabsent when not univ ->
-           set_row_field e1 f2
-       | Rabsent, Rabsent -> ()
-       | _ -> raise (Unify []))
-     pairs
- 
-+let check_conditional env (pairs, tpl1, l, row2) tpls cont =
-+  let tpl1 =
-+    List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
-+  let included =
-+    List.for_all
-+      (fun (t1,t2) ->
-+        List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
-+          tpls)
-+      tpl1 in
-+  if tpl1 = [] || included then cont tpls else
-+  match get_row_field l row2 with
-+    Rpresent _ -> cont (tpl1 @ tpls)
-+  | Rabsent -> cont tpls
-+  | Reither (c, tl2, _, tpl2, e2) ->
-+      if not c || tl2 = [] then begin
-+        let snap = Btype.snapshot () in
-+        let ok =
-+          try
-+            begin match tl2 with
-+              [] ->
-+                set_row_field e2 (Rpresent None)
-+            | t::tl ->
-+                set_row_field e2 (Rpresent (Some t));
-+                List.iter (unify env t) tl
-+            end;
-+            List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
-+            true
-+          with Unify _ -> false
-+        in
-+        if ok then cont (tpl1 @ tpls);
-+        Btype.backtrack snap
-+      end;
-+      cont tpls
-+
-+let rec check_conditionals inst_nongen env cdtls tpls =
-+  match cdtls with
-+    [] ->
-+      let tpls =
-+        List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in
-+      if tpls = [] then () else begin
-+        delayed_conditionals := [];
-+        let tl1, tl2 = List.split tpls in
-+        let type_pairs = TypePairs.create 13 in
-+        List.iter2 (moregen false type_pairs env) tl2 tl1;
-+        check_conditionals inst_nongen env !delayed_conditionals []
-+      end
-+  | cdtl :: cdtls ->
-+      check_conditional env cdtl tpls
-+        (check_conditionals inst_nongen env cdtls)
-+
-+
- (* Must empty univar_pairs first *)
- let moregen inst_nongen type_pairs env patt subj =
-   univar_pairs := [];
--  moregen inst_nongen type_pairs env patt subj
-+  delayed_conditionals := [];
-+  try
-+    moregen inst_nongen type_pairs env patt subj;
-+    check_conditionals inst_nongen env !delayed_conditionals [];
-+    univar_pairs := [];
-+    delayed_conditionals := []
-+  with exn ->
-+    univar_pairs := [];
-+    delayed_conditionals := [];
-+    raise exn
-+
- 
-+(* old implementation
- (*
-    Non-generic variable can be instanciated only if [inst_nongen] is
-    true. So, [inst_nongen] should be set to false if the subject might
-@@ -2128,6 +2404,7 @@
-   in
-   current_level := old_level;
-   res
-+*)
- 
- 
- (* Alternative approach: "rigidify" a type scheme,
-@@ -2296,30 +2573,36 @@
-     {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
-   | _ -> raise Cannot_expand
-   with Cannot_expand ->
-+  let eqtype_rec = eqtype rename type_pairs subst env in
-   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
-   if row1.row_closed <> row2.row_closed
-   || not row1.row_closed && (r1 <> [] || r2 <> [])
-   || filter_row_fields false (r1 @ r2) <> []
-   then raise (Unify []);
--  if not (static_row row1) then
--    eqtype rename type_pairs subst env row1.row_more row2.row_more;
-+  if not (static_row row1) then eqtype_rec row1.row_more row2.row_more;
-   List.iter
-     (fun (_,f1,f2) ->
-       match row_field_repr f1, row_field_repr f2 with
-         Rpresent(Some t1), Rpresent(Some t2) ->
--          eqtype rename type_pairs subst env t1 t2
--      | Reither(true, [], _, _), Reither(true, [], _, _) ->
--          ()
--      | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
--          eqtype rename type_pairs subst env t1 t2;
-+          eqtype_rec t1 t2
-+      | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) ->
-+          List.iter2
-+            (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
-+            tp1 tp2
-+      | Reither(false, t1::tl1, _, tpl1, _),
-+        Reither(false, t2::tl2, _, tpl2, _) ->
-+          eqtype_rec t1 t2;
-+          List.iter2
-+            (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
-+            tpl1 tpl2;
-           if List.length tl1 = List.length tl2 then
-             (* if same length allow different types (meaning?) *)
--            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
-+            List.iter2 eqtype_rec tl1 tl2
-           else begin
-             (* otherwise everything must be equal *)
--            List.iter (eqtype rename type_pairs subst env t1) tl2;
--            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
-+            List.iter (eqtype_rec t1) tl2;
-+            List.iter (fun t1 -> eqtype_rec t1 t2) tl1
-           end
-       | Rpresent None, Rpresent None -> ()
-       | Rabsent, Rabsent -> ()
-@@ -2334,6 +2617,8 @@
-   with
-     Unify _ -> false
- 
-+let () = equal' := equal
-+
- (* Must empty univar_pairs first *)  
- let eqtype rename type_pairs subst env t1 t2 =
-   univar_pairs := [];
-@@ -2770,14 +3055,14 @@
-           (fun (l,f as orig) -> match row_field_repr f with
-             Rpresent None ->
-               if posi then
--                (l, Reither(true, [], false, ref None)), Unchanged
-+                (l, Reither(true, [], false, [], ref None)), Unchanged
-               else
-                 orig, Unchanged
-           | Rpresent(Some t) ->
-               let (t', c) = build_subtype env visited loops posi level' t in
-               if posi && level > 0 then begin
-                 bound := t' :: !bound;
--                (l, Reither(false, [t'], false, ref None)), c
-+                (l, Reither(false, [t'], false, [], ref None)), c
-               end else
-                 (l, Rpresent(Some t')), c
-           | _ -> assert false)
-@@ -2960,11 +3245,11 @@
-       List.fold_left
-         (fun cstrs (_,f1,f2) ->
-           match row_field_repr f1, row_field_repr f2 with
--            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
-+            (Rpresent None|Reither(true,_,_,[],_)), Rpresent None ->
-               cstrs
-           | Rpresent(Some t1), Rpresent(Some t2) ->
-               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
--          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
-+          | Reither(false, t1::_, _, [], _), Rpresent(Some t2) ->
-               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
-           | Rabsent, _ -> cstrs
-           | _ -> raise Exit)
-@@ -2977,11 +3262,11 @@
-         (fun cstrs (_,f1,f2) ->
-           match row_field_repr f1, row_field_repr f2 with
-             Rpresent None, Rpresent None
--          | Reither(true,[],_,_), Reither(true,[],_,_)
-+          | Reither(true,[],_,[],_), Reither(true,[],_,[],_)
-           | Rabsent, Rabsent ->
-               cstrs
-           | Rpresent(Some t1), Rpresent(Some t2)
--          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
-+          | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) ->
-               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
-           | _ -> raise Exit)
-         cstrs pairs
-@@ -3079,16 +3364,26 @@
-       let fields = List.map
-           (fun (l,f) ->
-             let f = row_field_repr f in l,
--            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
--              let tyl' =
--                List.fold_left
--                  (fun tyl ty ->
--                    if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
--                    then tyl else ty::tyl)
--                  [ty] tyl
-+            match f with Reither(b, tyl, m, tp, e) ->
-+              let rem_dbl eq l =
-+                List.rev
-+                  (List.fold_left
-+                     (fun xs x -> if List.exists (eq x) xs then xs else x::xs)
-+                     [] l)
-+              in
-+              let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl
-+              and tp' =
-+                  List.filter
-+                    (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp
-+              in
-+              let tp' =
-+                rem_dbl
-+                  (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2'])
-+                  tp'
-               in
--              if List.length tyl' <= List.length tyl then
--                let f = Reither(b, List.rev tyl', m, ref None) in
-+              if List.length tyl' < List.length tyl
-+              || List.length tp' < List.length tp then
-+                let f = Reither(b, tyl', m, tp', ref None) in
-                 set_row_field e f;
-                 f
-               else f
-@@ -3344,9 +3639,9 @@
-       List.iter
-         (fun (l,fi) ->
-           match row_field_repr fi with
--            Reither (c, t1::(_::_ as tl), m, e) ->
-+            Reither (c, t1::(_::_ as tl), m, tp, e) ->
-               List.iter (unify env t1) tl;
--              set_row_field e (Reither (c, [t1], m, ref None))
-+              set_row_field e (Reither (c, [t1], m, tp, ref None))
-           | _ ->
-               ())
-         row.row_fields;
-Index: typing/includecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v
-retrieving revision 1.32
-diff -u -r1.32 includecore.ml
---- typing/includecore.ml	8 Aug 2005 05:40:52 -0000	1.32
-+++ typing/includecore.ml	2 Feb 2006 06:28:32 -0000
-@@ -71,10 +71,10 @@
- 	(fun (_, f1, f2) ->
- 	  match Btype.row_field_repr f1, Btype.row_field_repr f2 with
- 	    Rpresent(Some t1),
--	    (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
-+	    (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) ->
- 	      to_equal := (t1,t2) :: !to_equal; true
--	  | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
--	  | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
-+	  | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true
-+	  | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_)
- 	    when List.length tl1 = List.length tl2 && c1 = c2 ->
- 	      to_equal := List.combine tl1 tl2 @ !to_equal; true
- 	  | Rabsent, (Reither _ | Rabsent) -> true
-Index: typing/oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- typing/oprint.ml	23 Mar 2005 03:08:37 -0000	1.22
-+++ typing/oprint.ml	2 Feb 2006 06:28:33 -0000
-@@ -223,14 +223,18 @@
-       print_fields rest ppf []
-   | (s, t) :: l ->
-       fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
--and print_row_field ppf (l, opt_amp, tyl) =
-+and print_row_field ppf (l, opt_amp, tyl, tpl) =
-   let pr_of ppf =
-     if opt_amp then fprintf ppf " of@ &@ "
-     else if tyl <> [] then fprintf ppf " of@ "
--    else fprintf ppf ""
--  in
--  fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
--    tyl
-+  and pr_tp ppf (t1,t2) =
-+    fprintf ppf "@[%a =@ %a@]"
-+      print_out_type t1
-+      print_out_type t2
-+  in
-+  fprintf ppf "@[`%s%t%a%a@]" l pr_of
-+    (print_typlist print_out_type " &") tyl
-+    (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl
- and print_typlist print_elem sep ppf =
-   function
-     [] -> ()
-Index: typing/outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- typing/outcometree.mli	23 Mar 2005 03:08:37 -0000	1.14
-+++ typing/outcometree.mli	2 Feb 2006 06:28:33 -0000
-@@ -61,7 +61,8 @@
-       bool * out_variant * bool * (string list) option
-   | Otyp_poly of string list * out_type
- and out_variant =
--  | Ovar_fields of (string * bool * out_type list) list
-+  | Ovar_fields of
-+      (string * bool * out_type list * (out_type * out_type) list ) list
-   | Ovar_name of out_ident * out_type list
- 
- type out_class_type =
-Index: typing/parmatch.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v
-retrieving revision 1.70
-diff -u -r1.70 parmatch.ml
---- typing/parmatch.ml	24 Mar 2005 17:20:54 -0000	1.70
-+++ typing/parmatch.ml	2 Feb 2006 06:28:33 -0000
-@@ -568,11 +568,11 @@
-     List.fold_left
-       (fun nm (tag,f) ->
-         match Btype.row_field_repr f with
--        | Reither(_, _, false, e) ->
-+        | Reither(_, _, false, _, e) ->
-             (* m=false means that this tag is not explicitly matched *)
-             Btype.set_row_field e Rabsent;
-             None
--        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
-+        | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm)
-       row.row_name row.row_fields in
-   if not row.row_closed || nm != row.row_name then begin
-     (* this unification cannot fail *)
-@@ -605,8 +605,8 @@
-       List.for_all
-         (fun (tag,f) ->
-           match Btype.row_field_repr f with
--            Rabsent | Reither(_, _, false, _) -> true
--          | Reither (_, _, true, _)
-+            Rabsent | Reither(_, _, false, _, _) -> true
-+          | Reither (_, _, true, _, _)
-               (* m=true, do not discard matched tags, rather warn *)
-           | Rpresent _ -> List.mem tag fields)
-         row.row_fields
-@@ -739,7 +739,7 @@
-           match Btype.row_field_repr f with
-             Rabsent (* | Reither _ *) -> others
-           (* This one is called after erasing pattern info *)
--          | Reither (c, _, _, _) -> make_other_pat tag c :: others
-+          | Reither (c, _, _, _, _) -> make_other_pat tag c :: others
-           | Rpresent arg -> make_other_pat tag (arg = None) :: others)
-         [] row.row_fields
-     with
-Index: typing/printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.140
-diff -u -r1.140 printtyp.ml
---- typing/printtyp.ml	4 Jan 2006 16:55:50 -0000	1.140
-+++ typing/printtyp.ml	2 Feb 2006 06:28:33 -0000
-@@ -157,9 +157,12 @@
- and raw_field ppf = function
-     Rpresent None -> fprintf ppf "Rpresent None"
-   | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
--  | Reither (c,tl,m,e) ->
--      fprintf ppf "@[Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
--        raw_type_list tl m
-+  | Reither (c,tl,m,tpl,e) ->
-+      fprintf ppf "@[Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]"
-+        c raw_type_list tl m
-+        (raw_list
-+           (fun ppf (t1,t2) ->
-+             fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl
-         (fun ppf ->
-           match !e with None -> fprintf ppf " None"
-           | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
-@@ -219,8 +222,9 @@
-   List.for_all
-     (fun (_, f) ->
-        match row_field_repr f with
--       | Reither(c, l, _, _) ->
--           row.row_closed && if c then l = [] else List.length l = 1
-+       | Reither(c, l, _, pl, _) ->
-+           row.row_closed && pl = [] &&
-+           if c then l = [] else List.length l = 1
-        | _ -> true)
-     row.row_fields
- 
-@@ -392,13 +396,16 @@
- 
- and tree_of_row_field sch (l, f) =
-   match row_field_repr f with
--  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
--  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
--  | Reither(c, tyl, _, _) ->
--      if c (* contradiction: un constructeur constant qui a un argument *)
--      then (l, true, tree_of_typlist sch tyl)
--      else (l, false, tree_of_typlist sch tyl)
--  | Rabsent -> (l, false, [] (* une erreur, en fait *))
-+  | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], [])
-+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], [])
-+  | Reither(c, tyl, _, tpl, _) ->
-+      let ttpl =
-+        List.map
-+          (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2)
-+          tpl
-+      in
-+      (l, c && tpl = [], tree_of_typlist sch tyl, ttpl)
-+  | Rabsent -> (l, false, [], [] (* une erreur, en fait *))
- 
- and tree_of_typlist sch tyl =
-   List.map (tree_of_typexp sch) tyl
-Index: typing/typeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
-retrieving revision 1.85
-diff -u -r1.85 typeclass.ml
---- typing/typeclass.ml	22 Jul 2005 06:42:36 -0000	1.85
-+++ typing/typeclass.ml	2 Feb 2006 06:28:33 -0000
-@@ -727,7 +727,7 @@
-         {pexp_loc = loc; pexp_desc =
-          Pexp_match({pexp_loc = loc; pexp_desc =
-                      Pexp_ident(Longident.Lident"*opt*")},
--                    scases)} in
-+                    scases, false)} in
-       let sfun =
-         {pcl_loc = scl.pcl_loc; pcl_desc =
-          Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.178
-diff -u -r1.178 typecore.ml
---- typing/typecore.ml	6 Jan 2006 02:25:37 -0000	1.178
-+++ typing/typecore.ml	2 Feb 2006 06:28:33 -0000
-@@ -156,15 +156,21 @@
-       let field = row_field tag row in
-       begin match field with
-       | 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 ->
-+      | Reither (true, [], _, tpl, e) when not row.row_closed ->
-+          set_row_field e (Rpresent None);
-+          List.iter
-+            (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
-+            tpl
-+      | Reither (false, ty::tl, _, tpl, e) when not row.row_closed ->
-           set_row_field e (Rpresent (Some ty));
-+          List.iter
-+            (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
-+            tpl;
-           begin match opat with None -> assert false
-           | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
-           end
--      | Reither (c, l, true, e) when not row.row_fixed ->
--          set_row_field e (Reither (c, [], false, ref None))
-+      | Reither (c, l, true, tpl, e) when not row.row_fixed ->
-+          set_row_field e (Reither (c, [], false, [], ref None))
-       | _ -> ()
-       end;
-       (* Force check of well-formedness *)
-@@ -307,13 +313,13 @@
-         match row_field_repr f with
-           Rpresent None ->
-             (l,None) :: pats,
--            (l, Reither(true,[], true, ref None)) :: fields
-+            (l, Reither(true,[], true, [], ref None)) :: fields
-         | Rpresent (Some ty) ->
-             bound := ty :: !bound;
-             (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
-                       pat_type=ty})
-             :: pats,
--            (l, Reither(false, [ty], true, ref None)) :: fields
-+            (l, Reither(false, [ty], true, [], ref None)) :: fields
-         | _ -> pats, fields)
-       ([],[]) fields in
-   let row =
-@@ -337,6 +343,18 @@
-           pat pats in
-       rp { r with pat_loc = loc }
- 
-+let rec flatten_or_pat pat =
-+  match pat.pat_desc with
-+    Tpat_or (p1, p2, _) ->
-+      flatten_or_pat p1 @ flatten_or_pat p2
-+  | _ ->
-+      [pat]
-+
-+let all_variants pat =
-+  List.for_all
-+    (function {pat_desc=Tpat_variant _} -> true | _ -> false)
-+    (flatten_or_pat pat)
-+
- let rec find_record_qual = function
-   | [] -> None
-   | (Longident.Ldot (modname, _), _) :: _ -> Some modname
-@@ -423,7 +441,7 @@
-       let arg = may_map (type_pat env) sarg in
-       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
-       let row = { row_fields =
--                    [l, Reither(arg = None, arg_type, true, ref None)];
-+                    [l, Reither(arg = None, arg_type, true, [], ref None)];
-                   row_bound = arg_type;
-                   row_closed = false;
-                   row_more = newvar ();
-@@ -788,7 +806,7 @@
-        newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
-   | Pexp_function (p,_,(_,e)::_) ->
-        newty (Tarrow(p, newvar (), type_approx env e, Cok))
--  | Pexp_match (_, (_,e)::_) -> type_approx env e
-+  | Pexp_match (_, (_,e)::_, false) -> type_approx env e
-   | Pexp_try (e, _) -> type_approx env e
-   | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
-   | Pexp_ifthenelse (_,e,_) -> type_approx env e
-@@ -939,17 +957,26 @@
-         exp_loc = sexp.pexp_loc;
-         exp_type = ty_res;
-         exp_env = env }
--  | Pexp_match(sarg, caselist) ->
-+  | Pexp_match(sarg, caselist, multi) ->
-       let arg = type_exp env sarg in
-       let ty_res = newvar() in
-       let cases, partial =
--        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
-+        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
-       in
-       re {
-         exp_desc = Texp_match(arg, cases, partial);
-         exp_loc = sexp.pexp_loc;
-         exp_type = ty_res;
-         exp_env = env }
-+  | Pexp_multifun caselist ->
-+      let ty_arg = newvar() and ty_res = newvar() in
-+      let cases, partial =
-+        type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true
-+      in
-+      { exp_desc = Texp_function (cases, partial);
-+        exp_loc = sexp.pexp_loc;
-+        exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok));
-+        exp_env = env }
-   | Pexp_try(sbody, caselist) ->
-       let body = type_exp env sbody in
-       let cases, _ =
-@@ -1758,7 +1785,7 @@
-         {pexp_loc = loc; pexp_desc =
-          Pexp_match({pexp_loc = loc; pexp_desc =
-                      Pexp_ident(Longident.Lident"*opt*")},
--                    scases)} in
-+                    scases, false)} in
-       let sfun =
-         {pexp_loc = sexp.pexp_loc; pexp_desc =
-          Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
-@@ -1864,7 +1891,8 @@
- 
- (* Typing of match cases *)
- 
--and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
-+and type_cases ?in_function ?(multi=false)
-+    env ty_arg ty_res partial_loc caselist =
-   let ty_arg' = newvar () in
-   let pattern_force = ref [] in
-   let pat_env_list =
-@@ -1898,10 +1926,64 @@
-   let cases =
-     List.map2
-       (fun (pat, ext_env) (spat, sexp) ->
--        let exp = type_expect ?in_function ext_env sexp ty_res in
--        (pat, exp))
--      pat_env_list caselist
--  in
-+        let add_variant_case lab row ty_res ty_res' =
-+          let fi = List.assoc lab (row_repr row).row_fields in
-+          begin match row_field_repr fi with
-+            Reither (c, _, m, _, e) ->
-+              let row' =
-+                { row_fields =
-+                  [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)];
-+                  row_more = newvar (); row_bound = [ty_res; ty_res'];
-+                  row_closed = false; row_fixed = false; row_name = None }
-+              in
-+              unify_pat ext_env {pat with pat_type= newty (Tvariant row)}
-+                (newty (Tvariant row'))
-+          | _ ->
-+              unify_exp ext_env
-+                { exp_desc = Texp_tuple []; exp_type = ty_res;
-+                  exp_env = ext_env; exp_loc = sexp.pexp_loc }
-+                ty_res'
-+          end
-+        in
-+        pat,
-+        match pat.pat_desc with
-+          _ when multi && all_variants pat ->
-+            let ty_res' = newvar () in
-+            List.iter
-+              (function {pat_desc=Tpat_variant(lab,_,row)} ->
-+                add_variant_case lab row ty_res ty_res'
-+              | _ -> assert false)
-+              (flatten_or_pat pat);
-+            type_expect ?in_function ext_env sexp ty_res'
-+        | Tpat_alias (p, id) when multi && all_variants p ->
-+            let vd = Env.find_value (Path.Pident id) ext_env in
-+            let row' =
-+              match repr vd.val_type with
-+                {desc=Tvariant row'} -> row'
-+              | _ -> assert false
-+            in
-+            begin_def ();
-+            let tv = newvar () in
-+            let env = Env.add_value id {vd with val_type=tv} ext_env in
-+            let exp = type_exp env sexp in
-+            end_def ();
-+            generalize exp.exp_type;
-+            generalize tv;
-+            List.iter
-+              (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] ->
-+                let fi' = List.assoc lab (row_repr row').row_fields in
-+                let row' =
-+                  {row' with row_fields=[lab,fi']; row_more=newvar()} in
-+                unify_pat ext_env {pat with pat_type=tv'}
-+                  (newty (Tvariant row'));
-+                add_variant_case lab row ty_res ty'
-+              | _ -> assert false)
-+              (List.map (fun p -> p, instance_list [tv; exp.exp_type])
-+                 (flatten_or_pat p));
-+            {exp with exp_type = instance exp.exp_type}
-+        | _ ->
-+            type_expect ?in_function ext_env sexp ty_res)
-+      pat_env_list caselist in
-   let partial =
-     match partial_loc with None -> Partial
-     | Some loc -> Parmatch.check_partial loc cases
-Index: typing/typedecl.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v
-retrieving revision 1.75
-diff -u -r1.75 typedecl.ml
---- typing/typedecl.ml	16 Aug 2005 00:48:56 -0000	1.75
-+++ typing/typedecl.ml	2 Feb 2006 06:28:33 -0000
-@@ -432,8 +432,10 @@
-               match Btype.row_field_repr f with
-                 Rpresent (Some ty) ->
-                   compute_same ty
--              | Reither (_, tyl, _, _) ->
--                  List.iter compute_same tyl
-+              | Reither (_, tyl, _, tpl, _) ->
-+                  List.iter compute_same tyl;
-+                  List.iter (compute_variance_rec true true true)
-+                    (List.map fst tpl @ List.map snd tpl)
-               | _ -> ())
-             row.row_fields;
-           compute_same row.row_more
-@@ -856,8 +858,8 @@
-               explain row.row_fields
-                 (fun (l,f) -> match Btype.row_field_repr f with
-                   Rpresent (Some t) -> t
--                | Reither (_,[t],_,_) -> t
--                | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
-+                | Reither (_,[t],_,_,_) -> t
-+                | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl)
-                 | _ -> Btype.newgenty (Ttuple[]))
-                 "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
-           | _ -> trivial ty'
-Index: typing/types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- typing/types.ml	9 Dec 2004 12:40:53 -0000	1.25
-+++ typing/types.ml	2 Feb 2006 06:28:33 -0000
-@@ -48,7 +48,9 @@
- 
- and row_field =
-     Rpresent of type_expr option
--  | Reither of bool * type_expr list * bool * row_field option ref
-+  | Reither of
-+      bool * type_expr list * bool *
-+      (type_expr * type_expr) list * row_field option ref
-   | Rabsent
- 
- and abbrev_memo =
-Index: typing/types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- typing/types.mli	9 Dec 2004 12:40:53 -0000	1.25
-+++ typing/types.mli	2 Feb 2006 06:28:33 -0000
-@@ -47,7 +47,9 @@
- 
- and row_field =
-     Rpresent of type_expr option
--  | Reither of bool * type_expr list * bool * row_field option ref
-+  | Reither of
-+      bool * type_expr list * bool *
-+      (type_expr * type_expr) list * row_field option ref
-         (* 1st true denotes a constant constructor *)
-         (* 2nd true denotes a tag in a pattern matching, and
-            is erased later *)
-Index: typing/typetexp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
-retrieving revision 1.54
-diff -u -r1.54 typetexp.ml
---- typing/typetexp.ml	22 Jul 2005 06:42:36 -0000	1.54
-+++ typing/typetexp.ml	2 Feb 2006 06:28:33 -0000
-@@ -207,9 +207,9 @@
-                 match Btype.row_field_repr f with
-                 | Rpresent (Some ty) ->
-                     bound := ty :: !bound;
--                    Reither(false, [ty], false, ref None)
-+                    Reither(false, [ty], false, [], ref None)
-                 | Rpresent None ->
--                    Reither (true, [], false, ref None)
-+                    Reither (true, [], false, [], ref None)
-                 | _ -> f)
-               row.row_fields
-           in
-@@ -273,13 +273,16 @@
-           (l, f) :: fields
-       in
-       let rec add_field fields = function
--          Rtag (l, c, stl) ->
-+          Rtag (l, c, stl, stpl) ->
-             name := None;
-             let f = match present with
-               Some present when not (List.mem l present) ->
--                let tl = List.map (transl_type env policy) stl in
--                bound := tl @ !bound;
--                Reither(c, tl, false, ref None)
-+                let transl_list = List.map (transl_type env policy) in
-+                let tl = transl_list stl in
-+                let stpl1, stpl2 = List.split stpl in
-+                let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in
-+                bound := tl @ tpl1 @ tpl2 @ !bound;
-+                Reither(c, tl, false, List.combine tpl1 tpl2, ref None)
-             | _ ->
-                 if List.length stl > 1 || c && stl <> [] then
-                   raise(Error(styp.ptyp_loc, Present_has_conjunction l));
-@@ -311,9 +314,9 @@
-                     begin match f with
-                       Rpresent(Some ty) ->
-                         bound := ty :: !bound;
--                        Reither(false, [ty], false, ref None)
-+                        Reither(false, [ty], false, [], ref None)
-                     | Rpresent None ->
--                        Reither(true, [], false, ref None)
-+                        Reither(true, [], false, [], ref None)
-                     | _ ->
-                         assert false
-                     end
-@@ -406,7 +409,8 @@
-               {row with row_fixed=true;
-                row_fields = List.map
-                  (fun (s,f as p) -> match Btype.row_field_repr f with
--                   Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
-+                   Reither (c, tl, m, tpl, r) ->
-+                     s, Reither (c, tl, true, tpl, r)
-                  | _ -> p)
-                  row.row_fields};
-         Btype.iter_row make_fixed_univars row
-Index: typing/unused_var.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
-retrieving revision 1.5
-diff -u -r1.5 unused_var.ml
---- typing/unused_var.ml	4 Jan 2006 16:55:50 -0000	1.5
-+++ typing/unused_var.ml	2 Feb 2006 06:28:33 -0000
-@@ -122,9 +122,11 @@
-   | Pexp_apply (e, lel) ->
-       expression ppf tbl e;
-       List.iter (fun (_, e) -> expression ppf tbl e) lel;
--  | Pexp_match (e, pel) ->
-+  | Pexp_match (e, pel, _) ->
-       expression ppf tbl e;
-       match_pel ppf tbl pel;
-+  | Pexp_multifun pel ->
-+      match_pel ppf tbl pel;
-   | Pexp_try (e, pel) ->
-       expression ppf tbl e;
-       match_pel ppf tbl pel;
-Index: bytecomp/matching.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v
-retrieving revision 1.67
-diff -u -r1.67 matching.ml
---- bytecomp/matching.ml	7 Sep 2005 16:07:48 -0000	1.67
-+++ bytecomp/matching.ml	2 Feb 2006 06:28:33 -0000
-@@ -1991,7 +1991,7 @@
-     List.iter
-       (fun (_, f) ->
-         match Btype.row_field_repr f with
--          Rabsent | Reither(true, _::_, _, _) -> ()
-+          Rabsent | Reither(true, _::_, _, _, _) -> ()
-         | _ -> incr num_constr)
-       row.row_fields
-   else
-Index: toplevel/genprintval.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v
-retrieving revision 1.38
-diff -u -r1.38 genprintval.ml
---- toplevel/genprintval.ml	13 Jun 2005 04:55:53 -0000	1.38
-+++ toplevel/genprintval.ml	2 Feb 2006 06:28:33 -0000
-@@ -293,7 +293,7 @@
-                   | (l, f) :: fields ->
-                       if Btype.hash_variant l = tag then
-                         match Btype.row_field_repr f with
--                        | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
-+                        | Rpresent(Some ty) | Reither(_,[ty],_,_,_) ->
-                             let args =
-                               tree_of_val (depth - 1) (O.field obj 1) ty in
-                             Oval_variant (l, Some args)
diff --git a/testlabl/multimatch.ml b/testlabl/multimatch.ml
deleted file mode 100644
index 7c9aa73f..00000000
--- a/testlabl/multimatch.ml
+++ /dev/null
@@ -1,158 +0,0 @@
-(* Simple example *)
-let f x =
-  (multimatch x with `A -> 1 | `B -> true),
-  (multimatch x with `A -> 1. | `B -> "1");;
-
-(* OK *)
-module M : sig
-  val f :
-    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =  bool] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
-  val f :
-    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =   int] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Should be good! *)
-module M : sig
-  val f :
-    [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
-end = struct let f = f end;;
-
-let f = multifun `A|`B as x -> f x;;
-
-(* Two-level example *)
-let f = multifun
-    `A -> (multifun `C -> 1 | `D -> 1.)
-  | `B -> (multifun `C -> true | `D -> "1");;
-
-(* OK *)
-module M : sig
-  val f :
-    [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
-     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
-  val f :
-    [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
-     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-module M : sig
-  val f :
-    [< `A & 'b = [< `C & 'a = int | `D] -> 'a
-     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples with hidden sharing *)
-let r = ref []
-let f = multifun `A -> 1 | `B -> true
-let g x = r := [f x];;
-
-(* Bad! *)
-module M : sig
-  val g : [< `A & 'a = int | `B & 'a = bool] -> unit
-end = struct let g = g end;;
-
-let r = ref []
-let f = multifun `A -> r | `B -> ref [];;
-(* Now OK *)
-module M : sig
-  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-(* Still OK *)
-let l : int list ref = r;;
-module M : sig
-  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples that would need unification *)
-let f = multifun `A -> (1, []) | `B -> (true, [])
-let g x = fst (f x);;
-(* Didn't work, now Ok *)
-module M : sig
-  val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
-end = struct let g = g end;;
-let g = multifun (`A|`B) as x -> g x;;
-
-(* Other examples *)
-
-let f x =
-  let a = multimatch x with `A -> 1 | `B -> "1" in
-  (multifun `A -> print_int | `B -> print_string) x a
-;;
-
-let f = multifun (`A|`B) as x -> f x;;
-
-type unit_op = [`Set of int | `Move of int]
-type int_op = [`Get]
-
-let op r =
-  multifun
-    `Get     -> !r
-  | `Set x   -> r := x
-  | `Move dx -> r := !r + dx
-;;
-
-let rec trace r = function
-    [] -> []
-  | op1 :: ops ->
-      multimatch op1 with
-        #int_op as op1 ->
-          let x = op r op1 in
-          x :: trace r ops
-      | #unit_op as op1 ->
-          op r op1;
-          trace r ops
-;;
-
-class point x = object
-  val mutable x : int = x
-  method get = x
-  method set y = x <- y
-  method move dx = x <- x + dx
-end;;
-
-let poly sort coeffs x =
-  let add, mul, zero =
-    multimatch sort with
-      `Int -> (+), ( * ), 0
-    | `Float -> (+.), ( *. ), 0.
-  in
-  let rec compute = function
-      []     -> zero
-    | c :: cs -> add c (mul x (compute cs))
-  in
-  compute coeffs
-;;
-
-module M : sig
-  val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-type ('a,'b) num_sort =
-  'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
-module M : sig
-  val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-
-(* type dispatch *)
-
-type num = [ `Int | `Float ]
-let print0 = multifun
-    `Int -> print_int
-  | `Float -> print_float
-;;
-let print1 = multifun
-    #num as x -> print0 x
-  | `List t -> List.iter (print0 t)
-  | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
-;;
-print1 (`Pair(`Int,`Float)) (1,1.0);;
diff --git a/testlabl/newlabels.ps b/testlabl/newlabels.ps
deleted file mode 100644
index 01eac194..00000000
--- a/testlabl/newlabels.ps
+++ /dev/null
@@ -1,1458 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
-%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
-%%Title: newlabels.dvi
-%%Pages: 2 0
-%%PageOrder: Ascend
-%%BoundingBox: 0 0 596 842
-%%EndComments
-%%BeginProcSet: PStoPS 1 15
-userdict begin
-[/showpage/erasepage/copypage]{dup where{pop dup load
- type/operatortype eq{1 array cvx dup 0 3 index cvx put
- bind def}{pop}ifelse}{pop}ifelse}forall
-[/letter/legal/executivepage/a4/a4small/b5/com10envelope
- /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
- /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
- {pop{}def}ifelse}{pop}ifelse}forall
-/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
- {pop def}ifelse}{def}ifelse
-/PStoPSmatrix matrix currentmatrix def
-/PStoPSxform matrix def/PStoPSclip{clippath}def
-/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
-/initmatrix{matrix defaultmatrix setmatrix}bind def
-/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
- [{currentpoint}stopped{$error/newerror false put{newpath}}
- {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
- {[/newpath cvx{/moveto cvx}{/lineto cvx}
- {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
- stopped{$error/errorname get/invalidaccess eq{cleartomark
- $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
- /initclip dup load dup type dup/operatortype eq{pop exch pop}
- {dup/arraytype eq exch/packedarraytype eq or
-  {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
-  {pop cvx}ifelse}ifelse
- {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
-/initgraphics{initmatrix newpath initclip 1 setlinewidth
- 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
- 10 setmiterlimit}bind def
-end
-%%EndProcSet
-%DVIPSCommandLine: dvips -f newlabels
-%DVIPSParameters: dpi=300
-%DVIPSSource:  TeX output 1999.10.26:1616
-%%BeginProcSet: tex.pro
-%!
-/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
-/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
-mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
-ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
-isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
-hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
-TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
-forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
-/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
-/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
-/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
-string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
-end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
-/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
-N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
-length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
-128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
-get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
-dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
-/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
-/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
-0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
-setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
-.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
-if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
-length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
-cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
-0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
-add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
-/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
-known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
-/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
-put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
-/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
-X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
-(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
-length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
-forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
-RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
-false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
-round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
-rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
-{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
-B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
-4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
-p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
-a}B /bos{/SS save N}B /eos{SS restore}B end
-
-%%EndProcSet
-TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
-@start
-%DVIPSBitmapFont: Fa cmr6 6 2
-/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
-D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
-8F0F> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fb cmmi8 8 4
-/Fb 4 111 df 85 D<0300038003000000000000000000000000001C00240046
-0046008C000C0018001800180031003100320032001C0009177F960C> 105
-D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
-00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
-D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
-80300980300E00120E7F8D15> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fc cmbx8 8 4
-/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
-800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
-3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D 109 D I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fd cmsy8 8 3
-/Fd 3 93 df 0 D<020002000200C218F2783AE00F800F80
-3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
-0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
-006040002013137E9218> 92 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fe cmtt12 12 43
-/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
-F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
-F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
-D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
-FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
-08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
-D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
-00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
-C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
-01C000E000E0007000700070003800380038003800380038003800380038003800700070
-007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
-FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
-01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
-7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
-F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
-003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
-9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
-E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
-38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
-FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
-FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
-03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
-03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
-FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
-C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
-I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
-0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
-FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
-0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
-007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
-C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
-FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
-01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
-E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
-1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
-E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
-000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
-9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
-003800003800003800003800003800003800003800003800003800003800003800003800
-00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I 91 D 93 D<1FF0003FFC007FFE00780F
-00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
-80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
-000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
-0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
-FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
-0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
-E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
-I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
-F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
-07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
-E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
-E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
-0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
-0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
-FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
-0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
-121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
-D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
-001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
-007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
-00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
-00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
-7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
-1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
-007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
-80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
-FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
-C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
-F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
-FFFFE0038000038000038000038000038000038000038000038000038000038000038070
-03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
-E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
-E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
-00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
-EE0000EE0000EE00007C00007C0000380017157F941A> I I<7FC7F87FCFFC7FC7F80703C00383
-8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
-C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
-00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
-6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
-C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
-F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Ff cmr8 8 3
-/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
-003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
-00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
-D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
-183FF07FF0FFF00D157E9412> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fg cmmi12 12 13
-/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
-0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
-7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
-004000000040000000800000008000000080000000800000010000000FE00000711C0001
-C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
-080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
-FE0000002000000020000000400000004000000040000000400000008000000080000000
-800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
-D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
-0300000300000600000600000600000C00000C00000C0000180000180000180000300000
-300000300000600000600000600000C00000C00000C00001800001800001800001800003
-00000300000300000600000600000600000C00000C00000C000018000018000018000030
-0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
-D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
-00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
-0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
-8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
-D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
-04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
-00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
-000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
-D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
-07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
-000080001E000080003C000100003C000100003C000100003C0001000078000200007800
-020000780002000078000200007000040000F000040000F0000800007000080000700010
-00007000200000380040000038008000001C01000000060600000001F800000021237DA1
-21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
-E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
-101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
-001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
-000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
-0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
-000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
-> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
-001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
-> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
-0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
-> 120 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fh cmti12 12 22
-/Fh 22 122 df 45 D<70F8F8F0E005057A840F> I<00F8
-C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
-00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
-D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
-0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
-237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
-780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
-9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
-E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
-00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
-8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
-E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
-000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
-000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
-00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
-F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
-700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
-80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
-003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
-002300430043008700870087000E000E001C001C001C0038003800384070807080708071
-0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
-C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
-20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
-3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
-038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
-700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
-6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
-E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
-70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
-40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
-0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
-0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
-700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
-0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
-7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
-001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
-00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
-000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
-00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
-08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
-F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
-8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
-8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
-1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
-D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
-0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
-00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
-03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
-1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fi cmbx12 12 20
-/Fi 20 122 df 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
-FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
-00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
-18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
-F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
-00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
-000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
-0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
-227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
-03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
-18167E951B> 97 D I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
-FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
-07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
-F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
-7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
-E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
-0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
-0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
-1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
-0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
-3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
-0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
-00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F00FFE0FFE00B247EA310> 105 D 108
-D I I<00FE0007FFC00F83E01E00F03E00F87C00
-7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
-F81F01F00F83E007FFC000FE0017167E951C> I I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
-E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
-FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
-80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
-80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
-F80011207F9F16> I I 120 D I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fj cmsy10 12 15
-/Fj 15 107 df 0 D<03F0000FFC001FFE003FFF007F
-FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
-FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
-060000000C0000001800000030000000300000006000000060000000C0000000C0000000
-C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
-30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
-27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
-000000C000000000006000000000003000000000003000000000001C00000000000E0000
-0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
-000000300000000000300000000000600000000000C00000000000C00000000001800000
-00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
-80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
-FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
-E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
-00180000180000300000300000600000600000C00000C00000C000018000018000030000
-0300000600000600000C00000C0000180000180000300000300000600000600000C00000
-C0000180000180000300000300000300000600000600000C00000C000018000018000030
-0000300000600000600000C00000400000183079A300> 54 D I<00008000018001F980070F000C0300180380180780
-3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
-E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
-7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
-A519> 59 D<000100000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
-D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
-000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
-78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
-0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
-00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
-003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
-D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
-00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
-000003C012317DA419> 102 D I 106 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fk cmr12 12 65
-/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
-003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-0038000700380007003800070038000700380007003800070038000700380007003C007F
-E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
-0700300007000000070000000700000007000000070000000700000007000000FFFFF800
-070078000700380007003800070038000700380007003800070038000700380007003800
-070038000700380007003800070038000700380007003800070038000700380007003800
-070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
-0038000700380007003800070038000700380007003800070038000700380007003800FF
-FFF800070038000700380007003800070038000700380007003800070038000700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
-00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
-0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
-07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
-001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
-1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
-0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
-7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-6000600060007000300030003000180018000C000C000400060003000100008000400020
-0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
-C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
-327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
-D I<70F8F8F87005057C840E> I<01F000071C000C0600180300
-3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
-F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
-3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
-800380038003800380038003800380038003800380038003800380038003800380038003
-800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
-002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
-C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
-200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
-07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
-F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
-03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
-000700000F00001700001700002700006700004700008700018700010700020700060700
-040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
-000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
-000000000070F8F8F87005157C940E> 58 D 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
-00800080018001000100010001000100010000000000000000000000038007C007C007C0
-038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
-05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
-203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
-000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
-0001F8FF800FFF20237EA225> 65 D I<0007E0100038183000E0063001C00170038000F007
-0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
-000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
-0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
-C0010000E0020000381C000007E0001C247DA223> I I 70 D<0007F008003C0C1800E0021801C0
-01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
-000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
-1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
-0078038000B801C000B800E00318003C0C080007F00020247DA226> I I I 75
-D I
-78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
-0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
-00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
-0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
-0FE0001F247DA226> I I 82 D<03F0200C0C601802603001E07000E0600060E00060E000
-60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
-C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
-C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
-4007800840078008C007800C800780048007800480078004800780040007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00001FFFE001E227EA123> I 86 D I 91 D 93
-D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
-00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
-D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
-7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
-0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
-16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
-F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
-17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
-00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
-7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
-0000070000070000070000FFF80007000007000007000007000007000007000007000007
-00000700000700000700000700000700000700000700000700000700000700000780007F
-F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
-7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
-0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
-15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
-700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
-70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
-000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
-00000000007007F000F00070007000700070007000700070007000700070007000700070
-00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
-I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
-000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
-7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
-003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
-3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
-00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
-0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
-F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
-01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
-000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
-> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
-00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
-0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
-10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
-0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
-1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
-0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
-017003827800FC7F18157F941B> I I I I I<3FFFC0380380300780200700600E
-00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
-80380080780180700780FFFF8012157F9416> I 124
-D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fl cmbx12 14.4 19
-/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
-FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
-7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
-00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
-0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
-003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
-31> 67 D
-76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
-03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
-007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
-007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
-07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
-A833> 79 D 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
-801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
-803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
-FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D I<00007FF000007FF000007FF0000007F0000007F0000007
-F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
-F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
-F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
-F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
-FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
-0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
-0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
-1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
-F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
-F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
-F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
-2A7EA915> I
-104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
-E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
-E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I 108 D 110 D<003FE00001FFFC0003F07E000FC01F801F80
-0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
-03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
-0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I I 114 D<03FE300FFFF03E03F078
-00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
-FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
-1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
-0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
-0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
-07F0E003F0C001FF80007F0014267FA51A> I I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fm cmr12 14.4 20
-/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
-D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
-F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
-F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
-000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
-7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
-00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
-001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
-003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
-D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
-1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
-9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
-E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
-1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
-0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
-0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
-00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
-3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
-F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
-D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
-C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
-D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
-07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
-000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
-00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
-00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
-C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
-272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
-000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
-007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
-8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
-00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
-01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
-01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
-C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
-F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
-1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
-E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
-007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
-D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
-007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
-0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
-0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
-0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
-1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
-0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
-0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
-F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
-1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
-0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
-F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
-1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
-1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
-00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
-00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
-E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
-8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
-000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
-000780000780000780000780000780000780000780000780000780000780000780000780
-0007804007804007804007804007804007804007804003C08001C08000E100003E001225
-7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
-F01C1A7E9921> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fn cmr17 20.74 18
-/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
-03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
-0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
-000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
-0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
-0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
-00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
-FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
-0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
-00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
-00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
-01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
-0000313D7CBB39> 67 D 76 D<000003FF00000000001E01E000000000F0003C000000
-03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
-0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
-00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
-0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
-01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
-FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
-FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
-0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
-00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
-00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
-01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
-0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
-00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
-001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
-01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
-0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
-0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
-D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
-03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
-E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
-00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
-03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
-7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
-03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
-E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
-001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
-03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
-7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
-FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
-0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
-3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
-00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
-000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
-0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
-257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
-00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
-18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
-0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
-000380000000000000000000000000000000000000000000000000000000000000000000
-0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
-C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
-01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
-03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
-FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
-F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
-0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
-07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
-C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
-28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
-000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
-7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
-000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
-000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
-C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
-E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
-D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
-00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
-0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
-80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
-00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
-0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
-07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
-01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
-000E08000003F00019357FB41E> I 118
-D E
-%EndDVIPSBitmapFont
-end
-%%EndProlog
-%%BeginSetup
-%%Feature: *Resolution 300dpi
-TeXDict begin
-%%PaperSize: a4
-
-userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
- matrix invertmatrix matrix concatmatrix
- matrix invertmatrix put
-%%EndSetup
-%%Page: (0,1) 1
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
-927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
-370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
-634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
-Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
-319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
-a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
-929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
-Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
-a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
-259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
-1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
-1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
-1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
-a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
-1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
-878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
-(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
-1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
-303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
-681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
-1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
-a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
-1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
-322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
-133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
-a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
-918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
-1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
-492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
-891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
-Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
-a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
-1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
-991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
-1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
-Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
-634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
-2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
-a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
-Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
-Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
-2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
-656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
-634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
-Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
-Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
-Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
-a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
-a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
-579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
-a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
-Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
-Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
-a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
-Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
-Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
-a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
-Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
-634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
-2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
-2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
-Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
-2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
-Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
-Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
-956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
-Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
-261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
-261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
-Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
-366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
-Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
-a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
-a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
-Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
-Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
-Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
-a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
-790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
-877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
-434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
-427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
-427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
-427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
-427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
-a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
-427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
-Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
-a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
-Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
-Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
-551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
-494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
-494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
-Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
-Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
-Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
-Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
-547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
-Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
-Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
-Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
-Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
-a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
-a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
-Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
-Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
-a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
-451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
-538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
-614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
-Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
-a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
-607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
-607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
-1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
-1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
-667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
-Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
-Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
-945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
-1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
-a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
-728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
-Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
-Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
-555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
-629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
-698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
-Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
-a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
-728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
-728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
-Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
-Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
-a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
-a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
-Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
-Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
-a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
-a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
-1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
-Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
-Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
-Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
-a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
-470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
-557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
-855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
-855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
-855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
-a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
-848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
-855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
-Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
-Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
-Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
-a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
-a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
-Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
-a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
-906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
-Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
-1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
-Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
-Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
-240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
-685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
-a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
-a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
-1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
-a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
-a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
-1009 1187 a(out-of-order) p 1283 1187 a(application) p
-1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
-1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
-431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
-1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
-1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
-1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
-Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
-a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
-Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
-355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
-1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
-884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
-1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
-1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
-1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
-a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
-728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
-1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
-1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
-a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
-184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
-440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
-1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
-1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
-1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
-a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
-363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
-1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
-927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
-312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
-1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
-902 1960 a(=) p 953 1960 a() 133 2020 y(val) p 235
-2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
-a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
-a(=) p 773 2020 a() 133 2080 y(val) p 235 2080 a(f3) p
-312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
-2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
-927 2080 a(=) p 978 2080 a() 133 2140 y(#) p 184
-2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
-a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
-722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
-2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
-a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a() 133
-2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
-a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
-645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
-a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
-543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
-850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
-1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
-1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
-261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
-204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
-a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
-a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
-2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
-2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
-a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
-Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
-a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
-2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
-547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
-850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
-1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
-2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
-2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
-310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
-718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
-Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
-1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
-1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
-153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
-477 2796 a(principal.) 926 2937 y(2) p eop
-PStoPSsaved restore
-%%Page: (2,3) 2
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
-382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
-684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
-1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
-1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
-Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
-183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
-759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
-1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
-1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
-1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
-463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
-a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
-1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
-1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
-1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
-181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
-581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
-Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
-a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
-466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
-1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
-1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
-571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
-199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
-472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
-a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
-a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
-1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
-1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
-1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
-403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
-694 692 a(from) p 809 692 a(constructors) p 1086 692
-a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
-a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
-307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
-702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
-a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
-752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
-1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
-1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
-(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
-952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
-252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
-939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
-a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
-a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
-932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
-a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
-797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
-a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
-a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
-Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
-939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
-944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
-Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
-a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
-939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
-939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
-939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
-a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
-a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
-(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
-a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
-1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
-1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
-214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
-y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
-1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
-145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
-460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
-934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
-1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
-a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
-1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
-Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
-418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
-Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
-967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
-a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
-Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
-a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
-365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
-833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
-1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
-1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
-1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
-417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
-646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
-1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
-1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
-1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
-Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
-Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
-753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
-Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
-a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
-a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
-a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
-Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
-Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
-1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
-a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
-a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
-372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
-Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
-Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
-Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
-Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
-a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
-1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
-Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
-a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
-a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
-1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
-Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
-a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
-a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
-1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
-1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
-1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
-211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
-Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
-a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
-908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
-a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
-1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
-a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
-188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
-458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
-a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
-1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
-2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
-2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
-290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
-a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
-a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
-904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
-Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
-a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
-Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
-2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
-2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
-2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
-907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
-a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
-a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
-2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
-466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
-2937 y(3) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
-133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
-436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
-907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
-1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
-261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
-266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
-909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
-1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
-1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
-321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
-325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
-666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
-926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
-a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
-1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
-1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
-a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
-441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
-881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
-y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
-512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
-810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
-133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
-482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
-616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
-1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
-1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
-676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
-311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
-676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
-979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
-272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
-777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
-777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
-1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
-1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
-310 838 a(|marking) p 551 838 a(constructors) p 830 838
-a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
-1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
-1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
-536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
-1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
-898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
-a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
-244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
-958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
-1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
-a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
-958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
-469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
-1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
-1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
-a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
-a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
-1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
-1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
-922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
-a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
-1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
-a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
-363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
-a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
-1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
-1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
-Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
-380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
-678 1490 a(other) p 812 1490 a(features:) p 1029 1490
-a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
-1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
-1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
-394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
-692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
-978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
-a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
-a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
-191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
-647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
-1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
-1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
-1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
-283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
-603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
-l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
-a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
-845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
-1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
-a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
-y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
-482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
-a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
-1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
-a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
-2937 y(4) p eop
-PStoPSsaved restore
-%%Trailer
-end
-userdict /end-hook known{end-hook}if
-%%EOF
diff --git a/testlabl/objvariant.diffs b/testlabl/objvariant.diffs
deleted file mode 100644
index 75deb24c..00000000
--- a/testlabl/objvariant.diffs
+++ /dev/null
@@ -1,354 +0,0 @@
-? objvariants-3.09.1.diffs
-? objvariants.diffs
-Index: btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.37.4.1
-diff -u -r1.37.4.1 btype.ml
---- btype.ml	5 Dec 2005 13:18:42 -0000	1.37.4.1
-+++ btype.ml	16 Jan 2006 02:23:14 -0000
-@@ -177,7 +177,8 @@
-     Tvariant row -> iter_row f row
-   | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
-       Misc.may (fun (_,l) -> List.iter f l) row.row_name;
--      List.iter f row.row_bound
-+      List.iter f row.row_bound;
-+      List.iter (fun (s,k,t) -> f t) row.row_object
-   | _ -> assert false
- 
- let iter_type_expr f ty =
-@@ -224,7 +225,9 @@
-     | Some (path, tl) -> Some (path, List.map f tl) in
-   { row_fields = fields; row_more = more;
-     row_bound = !bound; row_fixed = row.row_fixed && fixed;
--    row_closed = row.row_closed; row_name = name; }
-+    row_closed = row.row_closed; row_name = name;
-+    row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
-+  }
- 
- let rec copy_kind = function
-     Fvar{contents = Some k} -> copy_kind k
-Index: ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.197.2.6
-diff -u -r1.197.2.6 ctype.ml
---- ctype.ml	15 Dec 2005 02:28:38 -0000	1.197.2.6
-+++ ctype.ml	16 Jan 2006 02:23:15 -0000
-@@ -1421,7 +1421,7 @@
-   newgenty
-     (Tvariant
-        {row_fields = fields; row_closed = closed; row_more = newvar();
--        row_bound = []; row_fixed = false; row_name = None })
-+        row_bound = []; row_fixed = false; row_name = None; row_object=[]})
- 
- (**** Unification ****)
- 
-@@ -1724,8 +1724,11 @@
-     else None
-   in
-   let bound = row1.row_bound @ row2.row_bound in
-+  let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
-+  let row_object = row1.row_object @ miss2 in
-   let row0 = {row_fields = []; row_more = more; row_bound = bound;
--              row_closed = closed; row_fixed = fixed; row_name = name} in
-+              row_closed = closed; row_fixed = fixed; row_name = name;
-+              row_object = row_object } in
-   let set_more row rest =
-     let rest =
-       if closed then
-@@ -1758,6 +1761,18 @@
-           raise (Unify ((mkvariant [l,f1] true,
-                          mkvariant [l,f2] true) :: trace)))
-       pairs;
-+    List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
-+    if row_object <> [] then begin
-+      List.iter
-+        (fun (l,f) ->
-+          match row_field_repr f with
-+            Rpresent (Some ty) ->
-+              let fi = build_fields generic_level row_object (newgenvar()) in
-+              unify env (newgenty (Tobject (fi, ref None))) ty
-+          | Rpresent None -> raise (Unify [])
-+          | _ -> ())
-+        (row_repr row1).row_fields
-+    end;
-   with exn ->
-     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
-   end
-@@ -2789,7 +2804,8 @@
-       let row =
-         { row_fields = List.map fst fields; row_more = newvar();
-           row_bound = !bound; row_closed = posi; row_fixed = false;
--          row_name = if c > Unchanged then None else row.row_name }
-+          row_name = if c > Unchanged then None else row.row_name;
-+          row_object = [] }
-       in
-       (newty (Tvariant row), Changed)
-   | Tobject (t1, _) ->
-Index: oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- oprint.ml	23 Mar 2005 03:08:37 -0000	1.22
-+++ oprint.ml	16 Jan 2006 02:23:15 -0000
-@@ -185,7 +185,7 @@
-       fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
-   | Otyp_stuff s -> fprintf ppf "%s" s
-   | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
--  | Otyp_variant (non_gen, row_fields, closed, tags) ->
-+  | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
-       let print_present ppf =
-         function
-           None | Some [] -> ()
-@@ -198,12 +198,17 @@
-               ppf fields
-         | Ovar_name (id, tyl) ->
-             fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
-+      and print_object ppf obj =
-+        if obj <> [] then
-+          fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
-       in
--      fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "")
-+      fprintf ppf "%s[%s@[@[%a@]%a%a ]@]"
-+        (if non_gen then "_" else "")
-         (if closed then if tags = None then " " else "< "
-          else if tags = None then "> " else "? ")
-         print_fields row_fields
-         print_present tags
-+        print_object obj
-   | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
-       fprintf ppf "@[<1>(%a)@]" print_out_type ty
-   | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
-Index: outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- outcometree.mli	23 Mar 2005 03:08:37 -0000	1.14
-+++ outcometree.mli	16 Jan 2006 02:23:15 -0000
-@@ -59,6 +59,7 @@
-   | Otyp_var of bool * string
-   | Otyp_variant of
-       bool * out_variant * bool * (string list) option
-+      * (string * out_type) list
-   | Otyp_poly of string list * out_type
- and out_variant =
-   | Ovar_fields of (string * bool * out_type list) list
-Index: printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.139.2.2
-diff -u -r1.139.2.2 printtyp.ml
---- printtyp.ml	7 Dec 2005 23:37:27 -0000	1.139.2.2
-+++ printtyp.ml	16 Jan 2006 02:23:15 -0000
-@@ -244,7 +244,10 @@
-             visited_objects := px :: !visited_objects;
-           match row.row_name with
-           | Some(p, tyl) when namable_row row ->
--              List.iter (mark_loops_rec visited) tyl
-+              List.iter (mark_loops_rec visited) tyl;
-+              if not (static_row row) then
-+                List.iter (fun (s,k,t) -> mark_loops_rec visited t)
-+                  row.row_object
-           | _ ->
-               iter_row (mark_loops_rec visited) {row with row_bound = []}
-          end
-@@ -343,25 +346,27 @@
-                | _ -> false)
-             fields in
-         let all_present = List.length present = List.length fields in
-+        let static = row.row_closed && all_present in
-+        let obj =
-+          if static then [] else
-+          List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
-+        in
-+        let tags = if all_present then None else Some (List.map fst present) in
-         begin match row.row_name with
-         | Some(p, tyl) when namable_row row ->
-             let id = tree_of_path p in
-             let args = tree_of_typlist sch tyl in
--            if row.row_closed && all_present then
-+            if static then
-               Otyp_constr (id, args)
-             else
-               let non_gen = is_non_gen sch px in
--              let tags =
--                if all_present then None else Some (List.map fst present) in
-               Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
--                            row.row_closed, tags)
-+                            row.row_closed, tags, obj)
-         | _ ->
--            let non_gen =
--              not (row.row_closed && all_present) && is_non_gen sch px in
-+            let non_gen = not static && is_non_gen sch px in
-             let fields = List.map (tree_of_row_field sch) fields in
--            let tags =
--              if all_present then None else Some (List.map fst present) in
--            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
-+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
-+                          tags, obj)
-         end
-     | Tobject (fi, nm) ->
-         tree_of_typobject sch fi nm
-Index: typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.176.2.2
-diff -u -r1.176.2.2 typecore.ml
---- typecore.ml	11 Dec 2005 09:56:33 -0000	1.176.2.2
-+++ typecore.ml	16 Jan 2006 02:23:15 -0000
-@@ -170,7 +170,8 @@
-       (* Force check of well-formedness *)
-       unify_pat pat.pat_env pat
-         (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
--                        row_bound=[]; row_fixed=false; row_name=None}));
-+                        row_bound=[]; row_fixed=false; row_name=None;
-+                        row_object=[]}));
-   | _ -> ()
- 
- let rec iter_pattern f p =
-@@ -251,7 +252,7 @@
-       let ty = may_map (build_as_type env) p' in
-       newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
-                       row_bound=[]; row_name=None;
--                      row_fixed=false; row_closed=false})
-+                      row_fixed=false; row_closed=false; row_object=[]})
-   | Tpat_record lpl ->
-       let lbl = fst(List.hd lpl) in
-       if lbl.lbl_private = Private then p.pat_type else
-@@ -318,7 +319,8 @@
-       ([],[]) fields in
-   let row =
-     { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
--      row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
-+      row_closed = false; row_fixed = false; row_name = Some (path, tyl);
-+      row_object = [] }
-   in
-   let ty = newty (Tvariant row) in
-   let gloc = {loc with Location.loc_ghost=true} in
-@@ -428,7 +430,8 @@
-                   row_closed = false;
-                   row_more = newvar ();
-                   row_fixed = false;
--                  row_name = None } in
-+                  row_name = None;
-+                  row_object = [] } in
-       rp {
-         pat_desc = Tpat_variant(l, arg, row);
-         pat_loc = sp.ppat_loc;
-@@ -976,7 +979,8 @@
-                                   row_bound = [];
-                                   row_closed = false;
-                                   row_fixed = false;
--                                  row_name = None});
-+                                  row_name = None;
-+                                  row_object = []});
-         exp_env = env }
-   | Pexp_record(lid_sexp_list, opt_sexp) ->
-       let ty = newvar() in
-@@ -1261,8 +1265,30 @@
-                   assert false
-               end
-           | _ ->
--              (Texp_send(obj, Tmeth_name met),
--               filter_method env met Public obj.exp_type)
-+              let obj, met_ty =
-+                match expand_head env obj.exp_type with
-+                  {desc = Tvariant _} ->
-+                    let exp_ty = newvar () in
-+                    let met_ty = filter_method env met Public exp_ty in
-+                    let row =
-+                      {row_fields=[]; row_more=newvar();
-+                       row_bound=[]; row_closed=false;
-+                       row_fixed=false; row_name=None;
-+                       row_object=[met, Fpresent, met_ty]} in
-+                    unify_exp env obj (newty (Tvariant row));
-+                    let prim = Primitive.parse_declaration 1 ["%field1"] in
-+                    let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
-+                    let vd = {val_type = ty; val_kind = Val_prim prim} in
-+                    let esnd =
-+                      {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
-+                       exp_loc = Location.none; exp_type = ty; exp_env = env}
-+                    in
-+                    ({obj with exp_type = exp_ty;
-+                      exp_desc = Texp_apply(esnd,[Some obj, Required])},
-+                     met_ty)
-+                | _ -> (obj, filter_method env met Public obj.exp_type)
-+              in
-+              (Texp_send(obj, Tmeth_name met), met_ty)
-         in
-         if !Clflags.principal then begin
-           end_def ();
-Index: types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- types.ml	9 Dec 2004 12:40:53 -0000	1.25
-+++ types.ml	16 Jan 2006 02:23:15 -0000
-@@ -44,7 +44,9 @@
-       row_bound: type_expr list;
-       row_closed: bool;
-       row_fixed: bool;
--      row_name: (Path.t * type_expr list) option }
-+      row_name: (Path.t * type_expr list) option;
-+      row_object: (string * field_kind * type_expr) list;
-+    }
- 
- and row_field =
-     Rpresent of type_expr option
-Index: types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- types.mli	9 Dec 2004 12:40:53 -0000	1.25
-+++ types.mli	16 Jan 2006 02:23:15 -0000
-@@ -43,7 +43,9 @@
-       row_bound: type_expr list;
-       row_closed: bool;
-       row_fixed: bool;
--      row_name: (Path.t * type_expr list) option }
-+      row_name: (Path.t * type_expr list) option;
-+      row_object: (string * field_kind * type_expr) list;
-+    }
- 
- and row_field =
-     Rpresent of type_expr option
-Index: typetexp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
-retrieving revision 1.54
-diff -u -r1.54 typetexp.ml
---- typetexp.ml	22 Jul 2005 06:42:36 -0000	1.54
-+++ typetexp.ml	16 Jan 2006 02:23:15 -0000
-@@ -215,7 +215,8 @@
-           in
-           let row = { row_closed = true; row_fields = fields;
-                       row_bound = !bound; row_name = Some (path, args);
--                      row_fixed = false; row_more = newvar () } in
-+                      row_fixed = false; row_more = newvar ();
-+                      row_object = [] } in
-           let static = Btype.static_row row in
-           let row =
-             if static then row else
-@@ -262,7 +263,7 @@
-       let mkfield l f =
-         newty (Tvariant {row_fields=[l,f]; row_more=newvar();
-                          row_bound=[]; row_closed=true;
--                         row_fixed=false; row_name=None}) in
-+                         row_fixed=false; row_name=None; row_object=[]}) in
-       let add_typed_field loc l f fields =
-         try
-           let f' = List.assoc l fields in
-@@ -345,7 +346,7 @@
-       let row =
-         { row_fields = List.rev fields; row_more = newvar ();
-           row_bound = !bound; row_closed = closed;
--          row_fixed = false; row_name = !name } in
-+          row_fixed = false; row_name = !name; row_object = [] } in
-       let static = Btype.static_row row in
-       let row =
-         if static then row else
diff --git a/testlabl/objvariant.ml b/testlabl/objvariant.ml
deleted file mode 100644
index 3233e03c..00000000
--- a/testlabl/objvariant.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(* use with [cvs update -r objvariants typing] *)
-
-let f (x : [> ]) = x#m 3;;
-let o = object method m x = x+2 end;;
-f (`A o);;
-let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
-List.map f l;;
-let g = function `A x -> x#m 3 | `B x -> x#y;;
-List.map g l;;
-fun x -> ignore (x=f); List.map x l;;
-fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
-
-
-class cvar name =
-  object
-    method name = name
-    method print ppf = Format.pp_print_string ppf name
-  end
-
-type var = [`Var of cvar]
-
-class cint n =
-  object
-    method n = n
-    method print ppf = Format.pp_print_int ppf n
-  end
-
-class ['a] cadd (e1 : 'a) (e2 : 'a) =
-  object
-    constraint 'a = [> ]
-    method e1 = e1
-    method e2 = e2
-    method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
-  end
-
-type 'a expr = [var | `Int of cint | `Add of 'a cadd]
-
-type expr1 = expr1 expr
-
-let print = Format.printf "%t@."
-
-let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))
diff --git a/testlabl/printers.ml b/testlabl/printers.ml
deleted file mode 100644
index c80c42d6..00000000
--- a/testlabl/printers.ml
+++ /dev/null
@@ -1,11 +0,0 @@
-(* $Id$ *)
-
-open Types
-
-let ignore_abbrevs ppf ab =
-  let s = match ab with
-    Mnil -> "Mnil"
-  | Mlink _ -> "Mlink _"
-  | Mcons _ -> "Mcons _"
-  in
-  Format.pp_print_string ppf s
diff --git a/testlabl/sigsubst.ml b/testlabl/sigsubst.ml
deleted file mode 100644
index 9b6c957b..00000000
--- a/testlabl/sigsubst.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-module type Printable = sig
-  type t
-  val print : Format.formatter -> t -> unit
-end
-module type Comparable = sig
-  type t
-  val compare : t -> t -> int
-end
-module type PrintableComparable = sig
-  include Printable
-  include Comparable with type t = t
-end
-module type PrintableComparable = sig
-  type t
-  include Printable with type t := t
-  include Comparable with type t := t
-end
-module type PrintableComparable = sig
-  include Printable
-  include Comparable with type t := t
-end
-module type ComparableInt = Comparable with type t := int
-
-module type S = sig type t val f : t -> t end
-module type S' = S with type t := int
-
-module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
-module type S1 = S with type 'a t := 'a list
-module type S2 = sig
-  type 'a dict = (string * 'a) list
-  include S with type 'a t := 'a dict
-end
-
-
-module type S =
-  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
-module M = struct type exp = string type arg = int end
-module type S' = S with module T := M
diff --git a/testlabl/tests.ml b/testlabl/tests.ml
deleted file mode 100644
index c39d152f..00000000
--- a/testlabl/tests.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(* $Id$ *)
-
-let f1 = function `a x -> x=1 | `b -> true
-let f2 = function `a x -> x | `b -> true
-let f3 = function `b -> true
-let f x = f1 x && f2 x
-
-let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
-  String.sub s pos len
-
-let cCAMLtoTKpack_options w = function
-        `After v1 -> "-after"
-        | `Anchor v1 -> "-anchor"
-        | `Before v1 -> "-before"
-        | `Expand v1 -> "-expand"
-        | `Fill v1 -> "-fill"
-        | `In v1 -> "-in"
-        | `Ipadx v1 -> "-ipadx"
-        | `Ipady v1 -> "-ipady"
-        | `Padx v1 -> "-padx"
-        | `Pady v1 -> "-pady"
-        | `Side v1 -> "-side"
diff --git a/testlabl/valvirt.diffs b/testlabl/valvirt.diffs
deleted file mode 100644
index 2cf55742..00000000
--- a/testlabl/valvirt.diffs
+++ /dev/null
@@ -1,2349 +0,0 @@
-Index: utils/warnings.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v
-retrieving revision 1.23
-diff -u -r1.23 warnings.ml
---- utils/warnings.ml	15 Sep 2005 03:09:26 -0000	1.23
-+++ utils/warnings.ml	5 Apr 2006 02:25:59 -0000
-@@ -26,7 +26,7 @@
-   | Statement_type                   (* S *)
-   | Unused_match                     (* U *)
-   | Unused_pat
--  | Hide_instance_variable of string (* V *)
-+  | Instance_variable_override of string (* V *)
-   | Illegal_backslash                (* X *)
-   | Implicit_public_methods of string list
-   | Unerasable_optional_argument
-@@ -54,7 +54,7 @@
-   | Statement_type ->           's'
-   | Unused_match
-   | Unused_pat ->               'u'
--  | Hide_instance_variable _ -> 'v'
-+  | Instance_variable_override _ -> 'v'
-   | Illegal_backslash
-   | Implicit_public_methods _
-   | Unerasable_optional_argument
-@@ -126,9 +126,9 @@
-       String.concat " "
-         ("the following methods are overridden \
-           by the inherited class:\n " :: slist)
--  | Hide_instance_variable lab ->
--      "this definition of an instance variable " ^ lab ^
--      " hides a previously\ndefined instance variable of the same name."
-+  | Instance_variable_override lab ->
-+      "the instance variable " ^ lab ^ " is overridden.\n" ^
-+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
-   | Partial_application ->
-       "this function application is partial,\n\
-        maybe some arguments are missing."
-Index: utils/warnings.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v
-retrieving revision 1.16
-diff -u -r1.16 warnings.mli
---- utils/warnings.mli	15 Sep 2005 03:09:26 -0000	1.16
-+++ utils/warnings.mli	5 Apr 2006 02:25:59 -0000
-@@ -26,7 +26,7 @@
-   | Statement_type                   (* S *)
-   | Unused_match                     (* U *)
-   | Unused_pat
--  | Hide_instance_variable of string (* V *)
-+  | Instance_variable_override of string (* V *)
-   | Illegal_backslash                (* X *)
-   | Implicit_public_methods of string list
-   | Unerasable_optional_argument
-Index: parsing/parser.mly
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
-retrieving revision 1.123
-diff -u -r1.123 parser.mly
---- parsing/parser.mly	23 Mar 2005 03:08:37 -0000	1.123
-+++ parsing/parser.mly	5 Apr 2006 02:25:59 -0000
-@@ -623,6 +623,8 @@
-       { [] }
-   | class_fields INHERIT class_expr parent_binder
-       { Pcf_inher ($3, $4) :: $1 }
-+  | class_fields VAL virtual_value
-+      { Pcf_valvirt $3 :: $1 }
-   | class_fields VAL value
-       { Pcf_val $3 :: $1 }
-   | class_fields virtual_method
-@@ -638,14 +640,20 @@
-     AS LIDENT
-           { Some $2 }
-   | /* empty */
--          {None}
-+          { None }
-+;
-+virtual_value:
-+    MUTABLE VIRTUAL label COLON core_type
-+      { $3, Mutable, $5, symbol_rloc () }
-+  | VIRTUAL mutable_flag label COLON core_type
-+      { $3, $2, $5, symbol_rloc () }
- ;
- value:
--        mutable_flag label EQUAL seq_expr
--          { $2, $1, $4, symbol_rloc () }
--      | mutable_flag label type_constraint EQUAL seq_expr
--          { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
--            symbol_rloc () }
-+    mutable_flag label EQUAL seq_expr
-+      { $2, $1, $4, symbol_rloc () }
-+  | mutable_flag label type_constraint EQUAL seq_expr
-+      { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
-+        symbol_rloc () }
- ;
- virtual_method:
-     METHOD PRIVATE VIRTUAL label COLON poly_type
-@@ -711,8 +719,12 @@
-   | class_sig_fields CONSTRAINT constrain       { Pctf_cstr  $3 :: $1 }
- ;
- value_type:
--    mutable_flag label COLON core_type
--      { $2, $1, Some $4, symbol_rloc () }
-+    VIRTUAL mutable_flag label COLON core_type
-+      { $3, $2, Virtual, $5, symbol_rloc () }
-+  | MUTABLE virtual_flag label COLON core_type
-+      { $3, Mutable, $2, $5, symbol_rloc () }
-+  | label COLON core_type
-+      { $1, Immutable, Concrete, $3, symbol_rloc () }
- ;
- method_type:
-     METHOD private_flag label COLON poly_type
-Index: parsing/parsetree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
-retrieving revision 1.42
-diff -u -r1.42 parsetree.mli
---- parsing/parsetree.mli	23 Mar 2005 03:08:37 -0000	1.42
-+++ parsing/parsetree.mli	5 Apr 2006 02:25:59 -0000
-@@ -152,7 +152,7 @@
- 
- and class_type_field =
-     Pctf_inher of class_type
--  | Pctf_val   of (string * mutable_flag * core_type option * Location.t)
-+  | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t)
-   | Pctf_virt  of (string * private_flag * core_type * Location.t)
-   | Pctf_meth  of (string * private_flag * core_type * Location.t)
-   | Pctf_cstr  of (core_type * core_type * Location.t)
-@@ -179,6 +179,7 @@
- 
- and class_field =
-     Pcf_inher of class_expr * string option
-+  | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
-   | Pcf_val   of (string * mutable_flag * expression * Location.t)
-   | Pcf_virt  of (string * private_flag * core_type * Location.t)
-   | Pcf_meth  of (string * private_flag * expression * Location.t)
-Index: parsing/printast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
-retrieving revision 1.29
-diff -u -r1.29 printast.ml
---- parsing/printast.ml	4 Jan 2006 16:55:50 -0000	1.29
-+++ parsing/printast.ml	5 Apr 2006 02:25:59 -0000
-@@ -353,10 +353,11 @@
-   | Pctf_inher (ct) ->
-       line i ppf "Pctf_inher\n";
-       class_type i ppf ct;
--  | Pctf_val (s, mf, cto, loc) ->
-+  | Pctf_val (s, mf, vf, ct, loc) ->
-       line i ppf
--        "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
--      option i core_type ppf cto;
-+        "Pctf_val \"%s\" %a %a %a\n" s
-+        fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
-+      core_type (i+1) ppf ct;
-   | Pctf_virt (s, pf, ct, loc) ->
-       line i ppf
-         "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
-@@ -428,6 +429,10 @@
-       line i ppf "Pcf_inher\n";
-       class_expr (i+1) ppf ce;
-       option (i+1) string ppf so;
-+  | Pcf_valvirt (s, mf, ct, loc) ->
-+      line i ppf
-+        "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-+      core_type (i+1) ppf ct;
-   | Pcf_val (s, mf, e, loc) ->
-       line i ppf
-         "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-Index: typing/btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.38
-diff -u -r1.38 btype.ml
---- typing/btype.ml	4 Jan 2006 16:55:50 -0000	1.38
-+++ typing/btype.ml	5 Apr 2006 02:25:59 -0000
-@@ -330,7 +330,7 @@
- 
- let unmark_class_signature sign =
-   unmark_type sign.cty_self;
--  Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
-+  Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars
- 
- let rec unmark_class_type =
-   function
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.200
-diff -u -r1.200 ctype.ml
---- typing/ctype.ml	6 Jan 2006 02:16:24 -0000	1.200
-+++ typing/ctype.ml	5 Apr 2006 02:25:59 -0000
-@@ -857,7 +857,7 @@
-         Tcty_signature
-           {cty_self = copy sign.cty_self;
-            cty_vars =
--             Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
-+             Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars;
-            cty_concr = sign.cty_concr;
-            cty_inher =
-              List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
-@@ -2354,10 +2354,11 @@
-   | CM_Val_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Non_mutable_value of string
-+  | CM_Non_concrete_value of string
-   | CM_Missing_value of string
-   | CM_Missing_method of string
-   | CM_Hide_public of string
--  | CM_Hide_virtual of string
-+  | CM_Hide_virtual of string * string
-   | CM_Public_method of string
-   | CM_Private_method of string
-   | CM_Virtual_method of string
-@@ -2390,8 +2391,8 @@
-            end)
-         pairs;
-       Vars.iter
--        (fun lab (mut, ty) ->
--           let (mut', ty') = Vars.find lab sign1.cty_vars in
-+        (fun lab (mut, v, ty) ->
-+           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)]))
-@@ -2437,7 +2438,7 @@
-              end
-            in
-            if Concr.mem lab sign1.cty_concr then err
--           else CM_Hide_virtual lab::err)
-+           else CM_Hide_virtual ("method", lab) :: err)
-         miss1 []
-     in
-     let missing_method = List.map (fun (m, _, _) -> m) miss2 in
-@@ -2455,11 +2456,13 @@
-     in
-     let error =
-       Vars.fold
--        (fun lab (mut, ty) err ->
-+        (fun lab (mut, vr, ty) err ->
-           try
--            let (mut', ty') = Vars.find lab sign1.cty_vars in
-+            let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
-             if mut = Mutable && mut' <> Mutable then
-               CM_Non_mutable_value lab::err
-+            else if vr = Concrete && vr' <> Concrete then
-+              CM_Non_concrete_value lab::err
-             else
-               err
-           with Not_found ->
-@@ -2467,6 +2470,14 @@
-         sign2.cty_vars error
-     in
-     let error =
-+      Vars.fold
-+        (fun lab (_,vr,_) err ->
-+          if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
-+            CM_Hide_virtual ("instance variable", lab) :: err
-+          else err)
-+        sign1.cty_vars error
-+    in
-+    let error =
-       List.fold_right
-         (fun e l ->
-            if List.mem e missing_method then l else CM_Virtual_method e::l)
-@@ -2516,8 +2527,8 @@
-              end)
-           pairs;
-         Vars.iter
--          (fun lab (mut, ty) ->
--             let (mut', ty') = Vars.find lab sign1.cty_vars in
-+          (fun lab (_, _, ty) ->
-+             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)]))
-@@ -2554,7 +2565,7 @@
-           end
-         in
-         if Concr.mem lab sign1.cty_concr then err
--        else CM_Hide_virtual lab::err)
-+        else CM_Hide_virtual ("method", lab) :: err)
-       miss1 []
-   in
-   let missing_method = List.map (fun (m, _, _) -> m) miss2 in
-@@ -2578,11 +2589,13 @@
-   in
-   let error =
-     Vars.fold
--      (fun lab (mut, ty) err ->
-+      (fun lab (mut, vr, ty) err ->
-          try
--           let (mut', ty') = Vars.find lab sign1.cty_vars in
-+           let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
-            if mut = Mutable && mut' <> Mutable then
-              CM_Non_mutable_value lab::err
-+           else if vr = Concrete && vr' <> Concrete then
-+             CM_Non_concrete_value lab::err
-            else
-              err
-          with Not_found ->
-@@ -2590,6 +2603,14 @@
-       sign2.cty_vars error
-   in
-   let error =
-+    Vars.fold
-+      (fun lab (_,vr,_) err ->
-+        if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
-+          CM_Hide_virtual ("instance variable", lab) :: err
-+        else err)
-+      sign1.cty_vars error
-+  in
-+  let error =
-     List.fold_right
-       (fun e l ->
-         if List.mem e missing_method then l else CM_Virtual_method e::l)
-@@ -3279,7 +3300,7 @@
- let nondep_class_signature env id sign =
-   { cty_self = nondep_type_rec env id sign.cty_self;
-     cty_vars =
--      Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
-+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
-         sign.cty_vars;
-     cty_concr = sign.cty_concr;
-     cty_inher =
-Index: typing/ctype.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
-retrieving revision 1.53
-diff -u -r1.53 ctype.mli
---- typing/ctype.mli	9 Dec 2004 12:40:53 -0000	1.53
-+++ typing/ctype.mli	5 Apr 2006 02:25:59 -0000
-@@ -170,10 +170,11 @@
-   | CM_Val_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Non_mutable_value of string
-+  | CM_Non_concrete_value of string
-   | CM_Missing_value of string
-   | CM_Missing_method of string
-   | CM_Hide_public of string
--  | CM_Hide_virtual of string
-+  | CM_Hide_virtual of string * string
-   | CM_Public_method of string
-   | CM_Private_method of string
-   | CM_Virtual_method of string
-Index: typing/includeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v
-retrieving revision 1.7
-diff -u -r1.7 includeclass.ml
---- typing/includeclass.ml	6 Mar 2000 22:11:57 -0000	1.7
-+++ typing/includeclass.ml	5 Apr 2006 02:25:59 -0000
-@@ -78,14 +78,17 @@
-   | CM_Non_mutable_value lab ->
-       fprintf ppf
-        "@[The non-mutable instance variable %s cannot become mutable@]" lab
-+  | CM_Non_concrete_value lab ->
-+      fprintf ppf
-+       "@[The virtual instance variable %s cannot become concrete@]" lab
-   | CM_Missing_value lab ->
-       fprintf ppf "@[The first class type has no instance variable %s@]" lab
-   | CM_Missing_method lab ->
-       fprintf ppf "@[The first class type has no method %s@]" lab
-   | CM_Hide_public lab ->
-      fprintf ppf "@[The public method %s cannot be hidden@]" lab
--  | CM_Hide_virtual lab ->
--      fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
-+  | CM_Hide_virtual (k, lab) ->
-+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
-   | CM_Public_method lab ->
-       fprintf ppf "@[The public method %s cannot become private" lab
-   | CM_Virtual_method lab ->
-Index: typing/oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- typing/oprint.ml	23 Mar 2005 03:08:37 -0000	1.22
-+++ typing/oprint.ml	5 Apr 2006 02:25:59 -0000
-@@ -291,8 +291,10 @@
-       fprintf ppf "@[<2>method %s%s%s :@ %a@]"
-         (if priv then "private " else "") (if virt then "virtual " else "")
-         name !out_type ty
--  | Ocsg_value (name, mut, ty) ->
--      fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
-+  | Ocsg_value (name, mut, vr, ty) ->
-+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
-+        (if mut then "mutable " else "")
-+        (if vr then "virtual " else "")
-         name !out_type ty
- 
- let out_class_type = ref print_out_class_type
-Index: typing/outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- typing/outcometree.mli	23 Mar 2005 03:08:37 -0000	1.14
-+++ typing/outcometree.mli	5 Apr 2006 02:25:59 -0000
-@@ -71,7 +71,7 @@
- and out_class_sig_item =
-   | Ocsg_constraint of out_type * out_type
-   | Ocsg_method of string * bool * bool * out_type
--  | Ocsg_value of string * bool * out_type
-+  | Ocsg_value of string * bool * bool * out_type
- 
- type out_module_type =
-   | Omty_abstract
-Index: typing/printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.140
-diff -u -r1.140 printtyp.ml
---- typing/printtyp.ml	4 Jan 2006 16:55:50 -0000	1.140
-+++ typing/printtyp.ml	5 Apr 2006 02:26:00 -0000
-@@ -650,7 +650,7 @@
-         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
-       in
-       List.iter (fun met -> mark_loops (method_type met)) fields;
--      Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
-+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
-   | Tcty_fun (_, ty, cty) ->
-       mark_loops ty;
-       prepare_class_type params cty
-@@ -682,13 +682,15 @@
-           csil (tree_of_constraints params)
-       in
-       let all_vars =
--        Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
-+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
-+      in
-       (* Consequence of PR#3607: order of Map.fold has changed! *)
-       let all_vars = List.rev all_vars in
-       let csil =
-         List.fold_left
--          (fun csil (l, m, t) ->
--             Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
-+          (fun csil (l, m, v, t) ->
-+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
-+            :: csil)
-           csil all_vars
-       in
-       let csil =
-@@ -763,7 +765,9 @@
-     List.exists
-       (fun (lab, _, ty) ->
-          not (lab = dummy_method || Concr.mem lab sign.cty_concr))
--      fields in
-+      fields
-+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
-+  in
- 
-   Osig_class_type
-     (virt, Ident.name id,
-Index: typing/subst.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v
-retrieving revision 1.49
-diff -u -r1.49 subst.ml
---- typing/subst.ml	4 Jan 2006 16:55:50 -0000	1.49
-+++ typing/subst.ml	5 Apr 2006 02:26:00 -0000
-@@ -178,7 +178,8 @@
- 
- let class_signature s sign =
-   { cty_self = typexp s sign.cty_self;
--    cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
-+    cty_vars =
-+      Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
-     cty_concr = sign.cty_concr;
-     cty_inher =
-       List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
-Index: typing/typeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
-retrieving revision 1.85
-diff -u -r1.85 typeclass.ml
---- typing/typeclass.ml	22 Jul 2005 06:42:36 -0000	1.85
-+++ typing/typeclass.ml	5 Apr 2006 02:26:00 -0000
-@@ -24,7 +24,7 @@
- 
- type error =
-     Unconsistent_constraint of (type_expr * type_expr) list
--  | Method_type_mismatch of string * (type_expr * type_expr) list
-+  | Field_type_mismatch of string * string * (type_expr * type_expr) list
-   | Structure_expected of class_type
-   | Cannot_apply of class_type
-   | Apply_wrong_label of label
-@@ -36,7 +36,7 @@
-   | Unbound_class_type_2 of Longident.t
-   | Abbrev_type_clash of type_expr * type_expr * type_expr
-   | Constructor_type_mismatch of string * (type_expr * type_expr) list
--  | Virtual_class of bool * string list
-+  | Virtual_class of bool * string list * string list
-   | Parameter_arity_mismatch of Longident.t * int * int
-   | Parameter_mismatch of (type_expr * type_expr) list
-   | Bad_parameters of Ident.t * type_expr * type_expr
-@@ -49,6 +49,7 @@
-   | Non_collapsable_conjunction of
-       Ident.t * Types.class_declaration * (type_expr * type_expr) list
-   | Final_self_clash of (type_expr * type_expr) list
-+  | Mutability_mismatch of string * mutable_flag
- 
- exception Error of Location.t * error
- 
-@@ -90,7 +91,7 @@
-       generalize_class_type cty
-   | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
-       Ctype.generalize sty;
--      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
-+      Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
-       List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
-   | Tcty_fun (_, ty, cty) ->
-       Ctype.generalize ty;
-@@ -152,7 +153,7 @@
-   | Tcty_signature sign ->
-       Ctype.closed_schema sign.cty_self
-         &&
--      Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
-+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
-         sign.cty_vars
-         true
-   | Tcty_fun (_, ty, cty) ->
-@@ -172,7 +173,7 @@
-       limited_generalize rv cty
-   | Tcty_signature sign ->
-       Ctype.limited_generalize rv sign.cty_self;
--      Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
-+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
-         sign.cty_vars;
-       List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
-         sign.cty_inher
-@@ -201,11 +202,25 @@
-    Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
- 
- (* Enter an instance variable in the environment *)
--let enter_val cl_num vars lab mut ty val_env met_env par_env =
--  let (id, val_env, met_env, par_env) as result =
--    enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
-+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)));
-+      Ctype.unify val_env (Ctype.instance ty) (Ctype.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)))
-+    | Not_found -> None, virt
-+  in
-+  let (id, _, _, _) as result =
-+    match id with Some id -> (id, val_env, met_env, par_env)
-+    | None ->
-+        enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
-   in
--  vars := Vars.add lab (id, mut, ty) !vars;
-+  vars := Vars.add lab (id, mut, virt, ty) !vars;
-   result
- 
- let inheritance self_type env concr_meths warn_meths loc parent =
-@@ -218,7 +233,7 @@
-       with Ctype.Unify trace ->
-         match trace with
-           _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
--            raise(Error(loc, Method_type_mismatch (n, rem)))
-+            raise(Error(loc, Field_type_mismatch ("method", n, rem)))
-         | _ ->
-             assert false
-       end;
-@@ -243,7 +258,7 @@
-   in
-   let ty = transl_simple_type val_env false sty in
-   try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
--    raise(Error(loc, Method_type_mismatch (lab, trace)))
-+    raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
- 
- let delayed_meth_specs = ref []
- 
-@@ -253,7 +268,7 @@
-   in
-   let unif ty =
-     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
--      raise(Error(loc, Method_type_mismatch (lab, trace)))
-+      raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
-   in
-   match sty.ptyp_desc, priv with
-     Ptyp_poly ([],sty), Public ->
-@@ -279,6 +294,15 @@
- 
- (*******************************)
- 
-+let add_val env loc lab (mut, virt, ty) val_sig = 
-+  let virt =
-+    try
-+      let (mut', virt', ty') = Vars.find lab val_sig in
-+      if virt' = Concrete then virt' else virt
-+    with Not_found -> virt
-+  in
-+  Vars.add lab (mut, virt, ty) val_sig
-+
- let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
-   function
-     Pctf_inher sparent ->
-@@ -293,25 +317,12 @@
-           parent
-       in
-       let val_sig =
--        Vars.fold
--          (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
--          cl_sig.cty_vars val_sig
--      in
-+        Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
-       (val_sig, concr_meths, inher)
- 
--  | Pctf_val (lab, mut, sty_opt, loc) ->
--      let (mut, ty) =
--        match sty_opt with
--          None     ->
--            let (mut', ty) =
--              try Vars.find lab val_sig with Not_found ->
--                raise(Error(loc, Unbound_val lab))
--            in
--            (if mut = Mutable then mut' else Immutable), ty
--        | Some sty ->
--            mut, transl_simple_type env false sty
--      in
--      (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
-+  | Pctf_val (lab, mut, virt, sty, loc) ->
-+      let ty = transl_simple_type env false sty in
-+      (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher)
- 
-   | Pctf_virt (lab, priv, sty, loc) ->
-       declare_method env meths self_type lab priv sty loc;
-@@ -397,7 +408,7 @@
- 
- let rec class_field cl_num self_type meths vars
-     (val_env, met_env, par_env, fields, concr_meths, warn_meths,
--     inh_vals, inher) =
-+     warn_vals, inher) =
-   function
-     Pcf_inher (sparent, super) ->
-       let parent = class_expr cl_num val_env par_env sparent in
-@@ -411,18 +422,23 @@
-           parent.cl_type
-       in
-       (* Variables *)
--      let (val_env, met_env, par_env, inh_vars, inh_vals) =
-+      let (val_env, met_env, par_env, inh_vars, warn_vals) =
-         Vars.fold
--          (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
-+          (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) ->
-+             let mut, vr, ty = info in
-              let (id, val_env, met_env, par_env) =
--               enter_val cl_num vars lab mut ty val_env met_env par_env
-+               enter_val cl_num vars true lab mut vr ty val_env met_env par_env
-+                 sparent.pcl_loc
-              in
--             if StringSet.mem lab inh_vals then
--               Location.prerr_warning sparent.pcl_loc
--                 (Warnings.Hide_instance_variable lab);
--             (val_env, met_env, par_env, (lab, id) :: inh_vars,
--              StringSet.add lab inh_vals))
--          cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
-+             let warn_vals =
-+               if vr = Virtual then warn_vals else
-+               if StringSet.mem lab warn_vals then
-+                 (Location.prerr_warning sparent.pcl_loc
-+                   (Warnings.Instance_variable_override lab); warn_vals)
-+               else StringSet.add lab warn_vals
-+             in
-+             (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals))
-+          cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
-       in
-       (* Inherited concrete methods *)
-       let inh_meths = 
-@@ -443,11 +459,26 @@
-       in
-       (val_env, met_env, par_env,
-        lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+       concr_meths, warn_meths, warn_vals, inher)
-+
-+  | Pcf_valvirt (lab, mut, styp, loc) ->
-+      if !Clflags.principal then Ctype.begin_def ();
-+      let ty = Typetexp.transl_simple_type val_env false styp in
-+      if !Clflags.principal then begin
-+        Ctype.end_def ();
-+        Ctype.generalize_structure ty
-+      end;
-+      let (id, val_env, met_env', par_env) =
-+        enter_val cl_num vars false lab mut Virtual ty
-+          val_env met_env par_env loc
-+      in
-+      (val_env, met_env', par_env,
-+       lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields,
-+       concr_meths, warn_meths, StringSet.remove lab warn_vals, inher)
- 
-   | Pcf_val (lab, mut, sexp, loc) ->
--      if StringSet.mem lab inh_vals then
--        Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
-+      if StringSet.mem lab warn_vals then
-+        Location.prerr_warning loc (Warnings.Instance_variable_override lab);
-       if !Clflags.principal then Ctype.begin_def ();
-       let exp =
-         try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
-@@ -457,17 +488,19 @@
-         Ctype.end_def ();
-         Ctype.generalize_structure exp.exp_type
-       end;
--      let (id, val_env, met_env, par_env) =
--        enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
--      in
--      (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+      let (id, val_env, met_env', par_env) =
-+        enter_val cl_num vars false lab mut Concrete exp.exp_type
-+          val_env met_env par_env loc
-+      in
-+      (val_env, met_env', par_env,
-+       lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields,
-+       concr_meths, warn_meths, StringSet.add lab warn_vals, inher)
- 
-   | Pcf_virt (lab, priv, sty, loc) ->
-       virtual_method val_env meths self_type lab priv sty loc;
-       let warn_meths = Concr.remove lab warn_meths in
-       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
--       inh_vals, inher)
-+       warn_vals, inher)
- 
-   | Pcf_meth (lab, priv, expr, loc)  ->
-       let (_, ty) =
-@@ -493,7 +526,7 @@
-           end
-       | _ -> assert false
-       with Ctype.Unify trace ->
--        raise(Error(loc, Method_type_mismatch (lab, trace)))
-+        raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
-       end;
-       let meth_expr = make_method cl_num expr in
-       (* backup variables for Pexp_override *)
-@@ -510,12 +543,12 @@
-           Cf_meth (lab, texp)
-         end in
-       (val_env, met_env, par_env, field::fields,
--       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
-+       Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher)
- 
-   | Pcf_cstr (sty, sty', loc) ->
-       type_constraint val_env sty sty' loc;
-       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
--       inh_vals, inher)
-+       warn_vals, inher)
- 
-   | Pcf_let (rec_flag, sdefs, loc) ->
-       let (defs, val_env) =
-@@ -545,7 +578,7 @@
-           ([], met_env, par_env)
-       in
-       (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+       concr_meths, warn_meths, warn_vals, inher)
- 
-   | Pcf_init expr ->
-       let expr = make_method cl_num expr in
-@@ -562,7 +595,7 @@
-           Cf_init texp
-         end in
-       (val_env, met_env, par_env, field::fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+       concr_meths, warn_meths, warn_vals, inher)
- 
- and class_structure cl_num final val_env met_env loc (spat, str) =
-   (* Environment for substructures *)
-@@ -616,7 +649,7 @@
-   Ctype.unify val_env self_type (Ctype.newvar ());
-   let sign =
-     {cty_self = public_self;
--     cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
-+     cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
-      cty_concr = concr_meths;
-      cty_inher = inher} in
-   let methods = get_methods self_type in
-@@ -628,7 +661,11 @@
-        be modified after this point *)
-     Ctype.close_object self_type;
-     let mets = virtual_methods {sign with cty_self = self_type} in
--    if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
-+    let vals =
-+      Vars.fold
-+        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
-+        sign.cty_vars [] in
-+    if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals)));
-     let self_methods =
-       List.fold_right
-         (fun (lab,kind,ty) rem ->
-@@ -1135,9 +1172,14 @@
-   in
- 
-   if cl.pci_virt = Concrete then begin
--    match virtual_methods (Ctype.signature_of_class_type typ) with
--      []   -> ()
--    | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
-+    let sign = Ctype.signature_of_class_type typ in
-+    let mets = virtual_methods sign in
-+    let vals =
-+      Vars.fold
-+        (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)));
-   end;
- 
-   (* Misc. *)
-@@ -1400,10 +1442,10 @@
-       Printtyp.report_unification_error ppf trace
-         (fun ppf -> fprintf ppf "Type")
-         (fun ppf -> fprintf ppf "is not compatible with type")
--  | Method_type_mismatch (m, trace) ->
-+  | Field_type_mismatch (k, m, trace) ->
-       Printtyp.report_unification_error ppf trace
-         (function ppf ->
--           fprintf ppf "The method %s@ has type" m)
-+           fprintf ppf "The %s %s@ has type" k m)
-         (function ppf ->
-            fprintf ppf "but is expected to have type")
-   | Structure_expected clty ->
-@@ -1451,15 +1493,20 @@
-            fprintf ppf "The expression \"new %s\" has type" c)
-         (function ppf ->
-            fprintf ppf "but is used with type")
--  | Virtual_class (cl, mets) ->
-+  | Virtual_class (cl, mets, vals) ->
-       let print_mets ppf mets =
-         List.iter (function met -> fprintf ppf "@ %s" met) mets in
-       let cl_mark = if cl then "" else " type" in
-+      let missings =
-+        match mets, vals with
-+          [], _ -> "variables"
-+        | _, [] -> "methods"
-+        | _ -> "methods and variables"
-+      in
-       fprintf ppf
--        "@[This class%s should be virtual@ \
--           @[<2>The following methods are undefined :%a@]
--         @]"
--        cl_mark print_mets mets
-+        "@[This class%s should be virtual.@ \
-+           @[<2>The following %s are undefined :%a@]@]"
-+          cl_mark missings print_mets (mets @ vals)
-   | Parameter_arity_mismatch(lid, expected, provided) ->
-       fprintf ppf
-         "@[The class constructor %a@ expects %i type argument(s),@ \
-@@ -1532,3 +1579,10 @@
-            fprintf ppf "This object is expected to have type")
-         (function ppf ->
-            fprintf ppf "but has actually type")
-+  | Mutability_mismatch (lab, mut) ->
-+      let mut1, mut2 =
-+        if mut = Immutable then "mutable", "immutable"
-+        else "immutable", "mutable" in
-+      fprintf ppf
-+        "@[The instance variable is %s,@ it cannot be redefined as %s@]"
-+        mut1 mut2
-Index: typing/typeclass.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v
-retrieving revision 1.18
-diff -u -r1.18 typeclass.mli
---- typing/typeclass.mli	1 Dec 2003 00:32:11 -0000	1.18
-+++ typing/typeclass.mli	5 Apr 2006 02:26:00 -0000
-@@ -49,7 +49,7 @@
- 
- type error =
-     Unconsistent_constraint of (type_expr * type_expr) list
--  | Method_type_mismatch of string * (type_expr * type_expr) list
-+  | Field_type_mismatch of string * string * (type_expr * type_expr) list
-   | Structure_expected of class_type
-   | Cannot_apply of class_type
-   | Apply_wrong_label of label
-@@ -61,7 +61,7 @@
-   | Unbound_class_type_2 of Longident.t
-   | Abbrev_type_clash of type_expr * type_expr * type_expr
-   | Constructor_type_mismatch of string * (type_expr * type_expr) list
--  | Virtual_class of bool * string list
-+  | Virtual_class of bool * string list * string list
-   | Parameter_arity_mismatch of Longident.t * int * int
-   | Parameter_mismatch of (type_expr * type_expr) list
-   | Bad_parameters of Ident.t * type_expr * type_expr
-@@ -74,6 +74,7 @@
-   | Non_collapsable_conjunction of
-       Ident.t * Types.class_declaration * (type_expr * type_expr) list
-   | Final_self_clash of (type_expr * type_expr) list
-+  | Mutability_mismatch of string * mutable_flag
- 
- exception Error of Location.t * error
- 
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.178
-diff -u -r1.178 typecore.ml
---- typing/typecore.ml	6 Jan 2006 02:25:37 -0000	1.178
-+++ typing/typecore.ml	5 Apr 2006 02:26:00 -0000
-@@ -611,11 +611,11 @@
-       List.for_all
-         (function
-             Cf_meth _ -> true
--          | Cf_val (_,_,e) -> incr count; is_nonexpansive e
-+          | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
-           | Cf_init e -> is_nonexpansive e
-           | Cf_inher _ | Cf_let _ -> false)
-         fields &&
--      Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
-+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
-         vars true &&
-       !count = 0
-   | _ -> false
-@@ -1356,7 +1356,7 @@
-         (path_self, _) ->
-           let type_override (lab, snewval) =
-             begin try
--              let (id, _, ty) = Vars.find lab !vars in
-+              let (id, _, _, ty) = Vars.find lab !vars in
-               (Path.Pident id, type_expect env snewval (instance ty))
-             with
-               Not_found ->
-Index: typing/typecore.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v
-retrieving revision 1.37
-diff -u -r1.37 typecore.mli
---- typing/typecore.mli	4 Mar 2005 14:51:31 -0000	1.37
-+++ typing/typecore.mli	5 Apr 2006 02:26:00 -0000
-@@ -38,7 +38,8 @@
-         string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
-         Typedtree.pattern *
-         (Ident.t * type_expr) Meths.t ref *
--        (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
-+            Vars.t ref *
-         Env.t * Env.t * Env.t
- val type_expect:
-         ?in_function:(Location.t * type_expr) ->
-Index: typing/typedtree.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v
-retrieving revision 1.36
-diff -u -r1.36 typedtree.ml
---- typing/typedtree.ml	25 Nov 2003 09:20:43 -0000	1.36
-+++ typing/typedtree.ml	5 Apr 2006 02:26:00 -0000
-@@ -106,7 +106,7 @@
- 
- and class_field =
-     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
--  | Cf_val of string * Ident.t * expression
-+  | Cf_val of string * Ident.t * expression option * bool
-   | Cf_meth of string * expression
-   | Cf_let of rec_flag * (pattern * expression) list *
-               (Ident.t * expression) list
-@@ -140,7 +140,8 @@
-   | Tstr_recmodule of (Ident.t * module_expr) list
-   | Tstr_modtype of Ident.t * module_type
-   | Tstr_open of Path.t
--  | Tstr_class of (Ident.t * int * string list * class_expr) list
-+  | Tstr_class of
-+      (Ident.t * int * string list * class_expr * virtual_flag) list
-   | Tstr_cltype of (Ident.t * cltype_declaration) list
-   | Tstr_include of module_expr * Ident.t list
- 
-Index: typing/typedtree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v
-retrieving revision 1.34
-diff -u -r1.34 typedtree.mli
---- typing/typedtree.mli	25 Nov 2003 09:20:43 -0000	1.34
-+++ typing/typedtree.mli	5 Apr 2006 02:26:00 -0000
-@@ -107,7 +107,8 @@
- and class_field =
-     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
-     (* Inherited instance variables and concrete methods *)
--  | Cf_val of string * Ident.t * expression
-+  | Cf_val of string * Ident.t * expression option * bool
-+        (* None = virtual, true = override *)
-   | Cf_meth of string * expression
-   | Cf_let of rec_flag * (pattern * expression) list *
-               (Ident.t * expression) list
-@@ -141,7 +142,8 @@
-   | Tstr_recmodule of (Ident.t * module_expr) list
-   | Tstr_modtype of Ident.t * module_type
-   | Tstr_open of Path.t
--  | Tstr_class of (Ident.t * int * string list * class_expr) list
-+  | Tstr_class of
-+      (Ident.t * int * string list * class_expr * virtual_flag) list
-   | Tstr_cltype of (Ident.t * cltype_declaration) list
-   | Tstr_include of module_expr * Ident.t list
- 
-Index: typing/typemod.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v
-retrieving revision 1.73
-diff -u -r1.73 typemod.ml
---- typing/typemod.ml	8 Aug 2005 09:41:51 -0000	1.73
-+++ typing/typemod.ml	5 Apr 2006 02:26:00 -0000
-@@ -17,6 +17,7 @@
- open Misc
- open Longident
- open Path
-+open Asttypes
- open Parsetree
- open Types
- open Typedtree
-@@ -667,8 +668,9 @@
-         let (classes, new_env) = Typeclass.class_declarations env cl in
-         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
-         (Tstr_class
--           (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
--              (i, s, m, c)) classes) ::
-+           (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)) classes) ::
-          Tstr_cltype
-            (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
-          Tstr_type
-Index: typing/types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- typing/types.ml	9 Dec 2004 12:40:53 -0000	1.25
-+++ typing/types.ml	5 Apr 2006 02:26:00 -0000
-@@ -90,7 +90,8 @@
-   | Val_prim of Primitive.description   (* Primitive *)
-   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
-   | Val_self of (Ident.t * type_expr) Meths.t ref *
--                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+                (Ident.t * Asttypes.mutable_flag *
-+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
-                 string * type_expr
-                                         (* Self *)
-   | Val_anc of (string * Ident.t) list * string
-@@ -156,7 +157,8 @@
- 
- and class_signature =
-   { cty_self: type_expr;
--    cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-+    cty_vars:
-+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
-     cty_concr: Concr.t;
-     cty_inher: (Path.t * type_expr list) list }
- 
-Index: typing/types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- typing/types.mli	9 Dec 2004 12:40:53 -0000	1.25
-+++ typing/types.mli	5 Apr 2006 02:26:00 -0000
-@@ -91,7 +91,8 @@
-   | Val_prim of Primitive.description   (* Primitive *)
-   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
-   | Val_self of (Ident.t * type_expr) Meths.t ref *
--                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+                (Ident.t * Asttypes.mutable_flag *
-+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
-                 string * type_expr
-                                         (* Self *)
-   | Val_anc of (string * Ident.t) list * string
-@@ -158,7 +159,8 @@
- 
- and class_signature =
-   { cty_self: type_expr;
--    cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-+    cty_vars:
-+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
-     cty_concr: Concr.t;
-     cty_inher: (Path.t * type_expr list) list }
- 
-Index: typing/unused_var.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
-retrieving revision 1.5
-diff -u -r1.5 unused_var.ml
---- typing/unused_var.ml	4 Jan 2006 16:55:50 -0000	1.5
-+++ typing/unused_var.ml	5 Apr 2006 02:26:00 -0000
-@@ -245,7 +245,7 @@
-   match cf with
-   | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
-   | Pcf_val (_, _, e, _) -> expression ppf tbl e;
--  | Pcf_virt _ -> ()
-+  | Pcf_virt _ | Pcf_valvirt _ -> ()
-   | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
-   | Pcf_cstr _ -> ()
-   | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
-Index: bytecomp/translclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
-retrieving revision 1.38
-diff -u -r1.38 translclass.ml
---- bytecomp/translclass.ml	13 Aug 2005 20:59:37 -0000	1.38
-+++ bytecomp/translclass.ml	5 Apr 2006 02:26:00 -0000
-@@ -133,10 +133,10 @@
-                        (fun _ -> lambda_unit) cl
-                    in
-                    (inh_init, lsequence obj_init' obj_init, true)
--               | Cf_val (_, id, exp) ->
-+               | Cf_val (_, id, Some exp, _) ->
-                    (inh_init, lsequence (set_inst_var obj id exp) obj_init,
-                     has_init)
--               | Cf_meth _ ->
-+               | Cf_meth _ | Cf_val _ ->
-                    (inh_init, obj_init, has_init)
-                | Cf_init _ ->
-                    (inh_init, obj_init, true)
-@@ -213,27 +213,17 @@
-   if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
-   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
-   let ids = Ident.create "ids" in
--  let i = ref len in
--  let getter, names, cl_init =
--    match vals with [] -> "get_method_labels", [], cl_init
--    | (_,id0)::vals' ->
--        incr i;
--        let i = ref (List.length vals) in
--        "new_methods_variables",
--        [transl_meth_list (List.map fst vals)],
--        Llet(Strict, id0, lfield ids 0,
--	     List.fold_right
--	       (fun (name,id) rem ->
--	         decr i;
--                 Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
--	       vals' cl_init)
-+  let i = ref (len + nvals) in
-+  let getter, names =
-+    if nvals = 0 then "get_method_labels", [] else
-+    "new_methods_variables", [transl_meth_list (List.map fst vals)]
-   in
-   Llet(StrictOpt, ids,
-        Lapply (oo_prim getter,
-                [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-        List.fold_right
-          (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
--         methl cl_init)
-+         (methl @ vals) cl_init)
- 
- let output_methods tbl methods lam =
-   match methods with
-@@ -283,8 +273,9 @@
-                     (vals, meths_super cla str.cl_meths meths)
-                     inh_init cl_init msubst top cl in
-                 (inh_init, cl_init, [], values)
--            | Cf_val (name, id, exp) ->
--                (inh_init, cl_init, methods, (name, id)::values)
-+            | Cf_val (name, id, exp, over) ->
-+                let values = if over then values else (name, id) :: values in
-+                (inh_init, cl_init, methods, values)
-             | Cf_meth (name, exp) ->
-                 let met_code = msubst true (transl_exp exp) in
-                 let met_code =
-@@ -342,27 +333,24 @@
- 	  assert (Path.same path path');
- 	  let lpath = transl_path path in
-           let inh = Ident.create "inh"
--          and inh_vals = Ident.create "vals"
--          and inh_meths = Ident.create "meths"
-+          and ofs = List.length vals + 1
-           and valids, methids = super in
-           let cl_init =
-             List.fold_left
-               (fun init (nm, id, _) ->
--                Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
-+                Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
-                      init))
-               cl_init methids in
-           let cl_init =
-             List.fold_left
-               (fun init (nm, id) ->
--                Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
-+                Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
-               cl_init valids in
-           (inh_init,
-            Llet (Strict, inh, 
- 		 Lapply(oo_prim "inherits", narrow_args @
- 			[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
--                 Llet(StrictOpt, obj_init, lfield inh 0,
--                 Llet(Alias, inh_vals, lfield inh 1,
--                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
-+                 Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
-       | _ ->
- 	  let core cl_init =
-             build_class_init cla true super inh_init cl_init msubst top cl
-@@ -397,12 +385,16 @@
-    XXX Il devrait etre peu couteux d'ecrire des classes :
-      class c x y = d e f
- *)
--let rec transl_class_rebind obj_init cl =
-+let rec transl_class_rebind obj_init cl vf =
-   match cl.cl_desc with
-     Tclass_ident path ->
-+      if vf = Concrete then begin
-+        try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
-+        with Not_found -> raise Exit
-+      end;
-       (path, obj_init)
-   | Tclass_fun (pat, _, cl, partial) ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       let build params rem =
-         let param = name_pattern "param" [pat, ()] in
-         Lfunction (Curried, param::params,
-@@ -414,14 +406,14 @@
-          Lfunction (Curried, params, rem) -> build params rem
-        | rem                              -> build [] rem)
-   | Tclass_apply (cl, oexprs) ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       (path, transl_apply obj_init oexprs)
-   | Tclass_let (rec_flag, defs, vals, cl) ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       (path, Translcore.transl_let rec_flag defs obj_init)
-   | Tclass_structure _ -> raise Exit
-   | Tclass_constraint (cl', _, _, _) ->
--      let path, obj_init = transl_class_rebind obj_init cl' in
-+      let path, obj_init = transl_class_rebind obj_init cl' vf in
-       let rec check_constraint = function
-           Tcty_constr(path', _, _) when Path.same path path' -> ()
-         | Tcty_fun (_, _, cty) -> check_constraint cty
-@@ -430,21 +422,21 @@
-       check_constraint cl.cl_type;
-       (path, obj_init)
- 
--let rec transl_class_rebind_0 self obj_init cl =
-+let rec transl_class_rebind_0 self obj_init cl vf =
-   match cl.cl_desc with
-     Tclass_let (rec_flag, defs, vals, cl) ->
--      let path, obj_init = transl_class_rebind_0 self obj_init cl in
-+      let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
-       (path, Translcore.transl_let rec_flag defs obj_init)
-   | _ ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       (path, lfunction [self] obj_init)
- 
--let transl_class_rebind ids cl =
-+let transl_class_rebind ids cl vf =
-   try
-     let obj_init = Ident.create "obj_init"
-     and self = Ident.create "self" in
-     let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
--    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
-+    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
-     if not (Translcore.check_recursive_lambda ids obj_init') then
-       raise(Error(cl.cl_loc, Illegal_class_expr));
-     let id = (obj_init' = lfunction [self] obj_init0) in
-@@ -592,9 +584,9 @@
- *)
- 
- 
--let transl_class ids cl_id arity pub_meths cl =
-+let transl_class ids cl_id arity pub_meths cl vflag =
-   (* First check if it is not only a rebind *)
--  let rebind = transl_class_rebind ids cl in
-+  let rebind = transl_class_rebind ids cl vflag in
-   if rebind <> lambda_unit then rebind else
- 
-   (* Prepare for heavy environment handling *)
-@@ -696,9 +688,7 @@
-   (* Simplest case: an object defined at toplevel (ids=[]) *)
-   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
- 
--  let concrete =
--    ids = [] ||
--    Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
-+  let concrete = (vflag = Concrete)
-   and lclass lam =
-     let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
-     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
-@@ -800,11 +790,11 @@
- 
- (* Wrapper for class compilation *)
- 
--let transl_class ids cl_id arity pub_meths cl =
--  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
-+let transl_class ids cl_id arity pub_meths cl vf =
-+  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf
- 
- let () =
--  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
-+  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete)
- 
- (* Error report *)
- 
-Index: bytecomp/translclass.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v
-retrieving revision 1.11
-diff -u -r1.11 translclass.mli
---- bytecomp/translclass.mli	12 Aug 2004 12:55:11 -0000	1.11
-+++ bytecomp/translclass.mli	5 Apr 2006 02:26:00 -0000
-@@ -16,7 +16,8 @@
- open Lambda
- 
- val transl_class :
--  Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
-+  Ident.t list -> Ident.t ->
-+  int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
- 
- type error = Illegal_class_expr | Tags of string * string
- 
-Index: bytecomp/translmod.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v
-retrieving revision 1.51
-diff -u -r1.51 translmod.ml
---- bytecomp/translmod.ml	12 Aug 2004 12:55:11 -0000	1.51
-+++ bytecomp/translmod.ml	5 Apr 2006 02:26:00 -0000
-@@ -317,10 +317,10 @@
-   | Tstr_open path :: rem ->
-       transl_structure fields cc rootpath rem
-   | Tstr_class cl_list :: rem ->
--      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
-       Lletrec(List.map
--                (fun (id, arity, meths, cl) ->
--                  (id, transl_class ids id arity meths cl))
-+                (fun (id, arity, meths, cl, vf) ->
-+                  (id, transl_class ids id arity meths cl vf))
-                 cl_list,
-               transl_structure (List.rev ids @ fields) cc rootpath rem)
-   | Tstr_cltype cl_list :: rem ->
-@@ -414,11 +414,11 @@
-   | Tstr_open path :: rem ->
-       transl_store subst rem
-   | Tstr_class cl_list :: rem ->
--      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
-       let lam =
-         Lletrec(List.map
--                  (fun (id, arity, meths, cl) ->
--                     (id, transl_class ids id arity meths cl))
-+                  (fun (id, arity, meths, cl, vf) ->
-+                     (id, transl_class ids id arity meths cl vf))
-                   cl_list,
-                 store_idents ids) in
-       Lsequence(subst_lambda subst lam,
-@@ -485,7 +485,7 @@
-   | Tstr_modtype(id, decl) :: rem -> defined_idents rem
-   | Tstr_open path :: rem -> defined_idents rem
-   | Tstr_class cl_list :: rem ->
--      List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem
-+      List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
-   | Tstr_cltype cl_list :: rem -> defined_idents rem
-   | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
- 
-@@ -603,14 +603,14 @@
-   | Tstr_class cl_list ->
-       (* we need to use unique names for the classes because there might
-          be a value named identically *)
--      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
-       List.iter set_toplevel_unique_name ids;
-       Lletrec(List.map
--                (fun (id, arity, meths, cl) ->
--                   (id, transl_class ids id arity meths cl))
-+                (fun (id, arity, meths, cl, vf) ->
-+                   (id, transl_class ids id arity meths cl vf))
-                 cl_list,
-               make_sequence
--                (fun (id, _, _, _) -> toploop_setvalue_id id)
-+                (fun (id, _, _, _, _) -> toploop_setvalue_id id)
-                 cl_list)
-   | Tstr_cltype cl_list ->
-       lambda_unit
-Index: driver/main_args.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v
-retrieving revision 1.48
-diff -u -r1.48 main_args.ml
---- driver/main_args.ml	4 Jan 2006 16:55:49 -0000	1.48
-+++ driver/main_args.ml	5 Apr 2006 02:26:00 -0000
-@@ -136,11 +136,11 @@
-       \032    E/e enable/disable fragile match\n\
-       \032    F/f enable/disable partially applied function\n\
-       \032    L/l enable/disable labels omitted in application\n\
--      \032    M/m enable/disable overridden method\n\
-+      \032    M/m enable/disable overridden methods\n\
-       \032    P/p enable/disable partial match\n\
-       \032    S/s enable/disable non-unit statement\n\
-       \032    U/u enable/disable unused match case\n\
--      \032    V/v enable/disable hidden instance variable\n\
-+      \032    V/v enable/disable overridden instance variables\n\
-       \032    Y/y enable/disable suspicious unused variables\n\
-       \032    Z/z enable/disable all other unused variables\n\
-       \032    X/x enable/disable all other warnings\n\
-Index: driver/optmain.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v
-retrieving revision 1.87
-diff -u -r1.87 optmain.ml
---- driver/optmain.ml	4 Jan 2006 16:55:49 -0000	1.87
-+++ driver/optmain.ml	5 Apr 2006 02:26:00 -0000
-@@ -173,7 +173,7 @@
-          \032    P/p enable/disable partial match\n\
-          \032    S/s enable/disable non-unit statement\n\
-          \032    U/u enable/disable unused match case\n\
--         \032    V/v enable/disable hidden instance variables\n\
-+         \032    V/v enable/disable overridden instance variables\n\
-          \032    Y/y enable/disable suspicious unused variables\n\
-          \032    Z/z enable/disable all other unused variables\n\
-          \032    X/x enable/disable all other warnings\n\
-Index: stdlib/camlinternalOO.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
-retrieving revision 1.14
-diff -u -r1.14 camlinternalOO.ml
---- stdlib/camlinternalOO.ml	25 Oct 2005 18:34:07 -0000	1.14
-+++ stdlib/camlinternalOO.ml	5 Apr 2006 02:26:00 -0000
-@@ -206,7 +206,11 @@
-      (table.methods_by_name, table.methods_by_label, table.hidden_meths,
-       table.vars, virt_meth_labs, vars)
-      :: table.previous_states;
--  table.vars <- Vars.empty;
-+  table.vars <-
-+    Vars.fold
-+      (fun lab info tvars ->
-+        if List.mem lab vars then Vars.add lab info tvars else tvars)
-+      table.vars Vars.empty;
-   let by_name = ref Meths.empty in
-   let by_label = ref Labs.empty in
-   List.iter2
-@@ -255,9 +259,11 @@
-   index
- 
- let new_variable table name =
--  let index = new_slot table in
--  table.vars <- Vars.add name index table.vars;
--  index
-+  try Vars.find name table.vars
-+  with Not_found ->
-+    let index = new_slot table in
-+    table.vars <- Vars.add name index table.vars;
-+    index
- 
- let to_array arr =
-   if arr = Obj.magic 0 then [||] else arr
-@@ -265,16 +271,17 @@
- let new_methods_variables table meths vals =
-   let meths = to_array meths in
-   let nmeths = Array.length meths and nvals = Array.length vals in
--  let index = new_variable table vals.(0) in
--  let res = Array.create (nmeths + 1) index in
--  for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
-+  let res = Array.create (nmeths + nvals) 0 in
-   for i = 0 to nmeths - 1 do
--    res.(i+1) <- get_method_label table meths.(i)
-+    res.(i) <- get_method_label table meths.(i)
-+  done;
-+  for i = 0 to nvals - 1 do
-+    res.(i+nmeths) <- new_variable table vals.(i)
-   done;
-   res
- 
- let get_variable table name =
--  Vars.find name table.vars
-+  try Vars.find name table.vars with Not_found -> assert false
- 
- let get_variables table names =
-   Array.map (get_variable table) names
-@@ -315,9 +322,12 @@
-   let init =
-     if top then super cla env else Obj.repr (super cla) in
-   widen cla;
--  (init, Array.map (get_variable cla) (to_array vals),
--   Array.map (fun nm -> get_method cla (get_method_label cla nm))
--     (to_array concr_meths))
-+  Array.concat
-+    [[| repr init |];
-+     magic (Array.map (get_variable cla) (to_array vals) : int array);
-+     Array.map
-+       (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
-+       (to_array concr_meths) ]
- 
- let make_class pub_meths class_init =
-   let table = create_table pub_meths in
-Index: stdlib/camlinternalOO.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
-retrieving revision 1.9
-diff -u -r1.9 camlinternalOO.mli
---- stdlib/camlinternalOO.mli	25 Oct 2005 18:34:07 -0000	1.9
-+++ stdlib/camlinternalOO.mli	5 Apr 2006 02:26:00 -0000
-@@ -46,8 +46,7 @@
- val init_class : table -> unit
- val inherits :
-     table -> string array -> string array -> string array ->
--    (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
--    (Obj.t * int array * closure array)
-+    (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array
- val make_class :
-     string array -> (table -> Obj.t -> t) ->
-     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
-@@ -79,6 +78,7 @@
- 
- (** {6 Builtins to reduce code size} *)
- 
-+(*
- val get_const : t -> closure
- val get_var : int -> closure
- val get_env : int -> int -> closure
-@@ -103,6 +103,7 @@
- val send_var : tag -> int -> int -> closure
- val send_env : tag -> int -> int -> int -> closure
- val send_meth : tag -> label -> int -> closure
-+*)
- 
- type impl =
-     GetConst
-Index: stdlib/sys.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v
-retrieving revision 1.142
-diff -u -r1.142 sys.ml
---- stdlib/sys.ml	22 Mar 2006 12:39:39 -0000	1.142
-+++ stdlib/sys.ml	5 Apr 2006 02:26:00 -0000
-@@ -78,4 +78,4 @@
- 
- (* OCaml version string, must be in the format described in sys.mli. *)
- 
--let ocaml_version = "3.10+dev4 (2006-03-22)";;
-+let ocaml_version = "3.10+dev5 (2006-04-05)";;
-Index: tools/depend.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v
-retrieving revision 1.9
-diff -u -r1.9 depend.ml
---- tools/depend.ml	23 Mar 2005 03:08:37 -0000	1.9
-+++ tools/depend.ml	5 Apr 2006 02:26:00 -0000
-@@ -87,7 +87,7 @@
- 
- and add_class_type_field bv = function
-     Pctf_inher cty -> add_class_type bv cty
--  | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
-+  | Pctf_val(_, _, _, ty, _) -> add_type bv ty
-   | Pctf_virt(_, _, ty, _) -> add_type bv ty
-   | Pctf_meth(_, _, ty, _) -> add_type bv ty
-   | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-@@ -280,6 +280,7 @@
- and add_class_field bv = function
-     Pcf_inher(ce, _) -> add_class_expr bv ce
-   | Pcf_val(_, _, e, _) -> add_expr bv e
-+  | Pcf_valvirt(_, _, ty, _)
-   | Pcf_virt(_, _, ty, _) -> add_type bv ty
-   | Pcf_meth(_, _, e, _) -> add_expr bv e
-   | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-Index: tools/ocamlprof.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v
-retrieving revision 1.38
-diff -u -r1.38 ocamlprof.ml
---- tools/ocamlprof.ml	24 Mar 2005 17:20:54 -0000	1.38
-+++ tools/ocamlprof.ml	5 Apr 2006 02:26:00 -0000
-@@ -328,7 +328,7 @@
-       rewrite_patexp_list iflag spat_sexp_list
-   | Pcf_init sexp ->
-       rewrite_exp iflag sexp
--  | Pcf_virt _ | Pcf_cstr _  -> ()
-+  | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _  -> ()
- 
- and rewrite_class_expr iflag cexpr =
-   match cexpr.pcl_desc with
-Index: otherlibs/labltk/browser/searchpos.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v
-retrieving revision 1.48
-diff -u -r1.48 searchpos.ml
---- otherlibs/labltk/browser/searchpos.ml	23 Mar 2005 03:08:37 -0000	1.48
-+++ otherlibs/labltk/browser/searchpos.ml	5 Apr 2006 02:26:01 -0000
-@@ -141,9 +141,8 @@
-         List.iter cfl ~f:
-           begin function
-               Pctf_inher cty -> search_pos_class_type cty ~pos ~env
--            | Pctf_val (_, _, Some ty, loc) ->
-+            | Pctf_val (_, _, _, ty, loc) ->
-                 if in_loc loc ~pos then search_pos_type ty ~pos ~env
--            | Pctf_val _ -> ()
-             | Pctf_virt (_, _, ty, loc) ->
-                 if in_loc loc ~pos then search_pos_type ty ~pos ~env
-             | Pctf_meth (_, _, ty, loc) ->
-@@ -675,7 +674,7 @@
-   | Tstr_modtype _ -> ()
-   | Tstr_open _ -> ()
-   | Tstr_class l ->
--      List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
-+      List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos)
-   | Tstr_cltype _ -> ()
-   | Tstr_include (m, _) -> search_pos_module_expr m ~pos
-   end
-@@ -685,7 +684,8 @@
-     begin function
-         Cf_inher (cl, _, _) ->
-           search_pos_class_expr cl ~pos
--      | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
-+      | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
-+      | Cf_val _ -> ()
-       | Cf_meth (_, exp) -> search_pos_expr exp ~pos
-       | Cf_let (_, pel, iel) ->
-           List.iter pel ~f:
-Index: ocamldoc/Makefile
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v
-retrieving revision 1.61
-diff -u -r1.61 Makefile
---- ocamldoc/Makefile	4 Jan 2006 16:55:49 -0000	1.61
-+++ ocamldoc/Makefile	5 Apr 2006 02:26:01 -0000
-@@ -31,7 +31,7 @@
- MKDIR=mkdir -p
- CP=cp -f
- OCAMLDOC=ocamldoc
--OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
-+OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
- OCAMLDOC_OPT=$(OCAMLDOC).opt
- OCAMLDOC_LIBCMA=odoc_info.cma
- OCAMLDOC_LIBCMI=odoc_info.cmi
-@@ -188,12 +188,12 @@
- 	../otherlibs/num/num.mli
- 
- all: exe lib
--	$(MAKE) manpages
- 
- exe: $(OCAMLDOC)
- lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
- 
- opt.opt: exeopt libopt
-+	$(MAKE) manpages
- exeopt: $(OCAMLDOC_OPT)
- libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
- debug:
-Index: ocamldoc/odoc_ast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v
-retrieving revision 1.27
-diff -u -r1.27 odoc_ast.ml
---- ocamldoc/odoc_ast.ml	4 Jan 2006 16:55:49 -0000	1.27
-+++ ocamldoc/odoc_ast.ml	5 Apr 2006 02:26:01 -0000
-@@ -88,7 +88,7 @@
-             ident_type_decl_list
-       | Typedtree.Tstr_class info_list ->
-           List.iter
--            (fun ((id,_,_,_) as ci) ->
-+            (fun ((id,_,_,_,_) as ci) ->
-               Hashtbl.add table (C (Name.from_ident id))
-                 (Typedtree.Tstr_class [ci]))
-             info_list
-@@ -146,7 +146,7 @@
- 
-     let search_class_exp table name =
-       match Hashtbl.find table (C name) with
--      | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
-+      | (Typedtree.Tstr_class [(_,_,_,ce,_)]) ->
-           (
-            try
-              let type_decl = search_type_declaration table name in
-@@ -184,7 +184,7 @@
-       let rec iter = function
-         | [] ->
-             raise Not_found
--        | Typedtree.Cf_val (_, ident, exp) :: q
-+        | Typedtree.Cf_val (_, ident, Some exp, _) :: q
-           when Name.from_ident ident = name ->
-             exp.Typedtree.exp_type
-         | _ :: q ->
-@@ -523,7 +523,8 @@
-               p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
-               q
- 
--        | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
-+        | (Parsetree.Pcf_val (label, mutable_flag, _, loc) |
-+           Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q ->
-             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 =
-Index: ocamldoc/odoc_sig.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v
-retrieving revision 1.37
-diff -u -r1.37 odoc_sig.ml
---- ocamldoc/odoc_sig.ml	4 Jan 2006 16:55:50 -0000	1.37
-+++ ocamldoc/odoc_sig.ml	5 Apr 2006 02:26:01 -0000
-@@ -107,7 +107,7 @@
-       | _ -> assert false
- 
-     let search_attribute_type name class_sig =
--      let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
-+      let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
-       type_expr
- 
-     let search_method_type name class_sig =
-@@ -269,7 +269,7 @@
-           [] -> pos_limit
-         | ele2 :: _ ->
-             match ele2 with
--              Parsetree.Pctf_val (_, _, _, loc)
-+              Parsetree.Pctf_val (_, _, _, _, loc)
-             | Parsetree.Pctf_virt (_, _, _, loc)
-             | Parsetree.Pctf_meth (_, _, _, loc)
-             | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
-@@ -330,7 +330,7 @@
-             in
-             ([], ele_comments)
- 
--        | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
-+        | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
-             (* of (string * mutable_flag * core_type option * Location.t)*)
-             let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-             let complete_name = Name.concat current_class_name name in
-Index: camlp4/camlp4/ast2pt.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v
-retrieving revision 1.36
-diff -u -r1.36 ast2pt.ml
---- camlp4/camlp4/ast2pt.ml	29 Jun 2005 04:11:26 -0000	1.36
-+++ camlp4/camlp4/ast2pt.ml	5 Apr 2006 02:26:01 -0000
-@@ -244,6 +244,7 @@
- ;
- value mkmutable m = if m then Mutable else Immutable;
- value mkprivate m = if m then Private else Public;
-+value mkvirtual m = if m then Virtual else Concrete;
- value mktrecord (loc, n, m, t) =
-   (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
- value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
-@@ -862,8 +863,8 @@
-   | CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
-   | CgMth loc s pf t ->
-       [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
--  | CgVal loc s b t ->
--      [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
-+  | CgVal loc s b v t ->
-+      [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
-   | CgVir loc s b t ->
-       [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
- and class_expr =
-@@ -907,7 +908,9 @@
-       [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
-   | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
-   | CrVir loc s b t ->
--      [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
-+      [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l]
-+  | CrVvr loc s b t ->
-+      [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ]
- ;
- 
- value interf ast = List.fold_right sig_item ast [];
-Index: camlp4/camlp4/mLast.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v
-retrieving revision 1.18
-diff -u -r1.18 mLast.mli
---- camlp4/camlp4/mLast.mli	29 Jun 2005 04:11:26 -0000	1.18
-+++ camlp4/camlp4/mLast.mli	5 Apr 2006 02:26:01 -0000
-@@ -180,7 +180,7 @@
-   | CgDcl of loc and list class_sig_item
-   | CgInh of loc and class_type
-   | CgMth of loc and string and bool and ctyp
--  | CgVal of loc and string and bool and ctyp
-+  | CgVal of loc and string and bool and bool and ctyp
-   | CgVir of loc and string and bool and ctyp ]
- and class_expr =
-   [ CeApp of loc and class_expr and expr
-@@ -196,7 +196,8 @@
-   | CrIni of loc and expr
-   | CrMth of loc and string and bool and expr and option ctyp
-   | CrVal of loc and string and bool and expr
--  | CrVir of loc and string and bool and ctyp ]
-+  | CrVir of loc and string and bool and ctyp
-+  | CrVvr of loc and string and bool and ctyp ]
- ;
- 
- external loc_of_ctyp : ctyp -> loc = "%field0";
-Index: camlp4/camlp4/reloc.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v
-retrieving revision 1.18
-diff -u -r1.18 reloc.ml
---- camlp4/camlp4/reloc.ml	29 Jun 2005 04:11:26 -0000	1.18
-+++ camlp4/camlp4/reloc.ml	5 Apr 2006 02:26:01 -0000
-@@ -350,7 +350,7 @@
-     | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1)
-     | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1)
-     | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3)
--    | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3)
-+    | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4)
-     | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ]
- and class_expr floc sh =
-   self where rec self =
-@@ -377,5 +377,6 @@
-     | CrMth loc x1 x2 x3 x4 ->
-         let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
-     | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3)
--    | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ]
-+    | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3)
-+    | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ]
- ;
-Index: camlp4/etc/pa_o.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v
-retrieving revision 1.66
-diff -u -r1.66 pa_o.ml
---- camlp4/etc/pa_o.ml	29 Jun 2005 04:11:26 -0000	1.66
-+++ camlp4/etc/pa_o.ml	5 Apr 2006 02:26:01 -0000
-@@ -1037,8 +1037,14 @@
-   class_str_item:
-     [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
-           <:class_str_item< inherit $ce$ $opt:pb$ >>
--      | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
--          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+      | "val"; "mutable"; lab = label; e = cvalue_binding ->
-+          <:class_str_item< value mutable $lab$ = $e$ >>
-+      | "val"; lab = label; e = cvalue_binding ->
-+          <:class_str_item< value $lab$ = $e$ >>
-+      | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp ->
-+          <:class_str_item< value virtual mutable $lab$ : $t$ >>
-+      | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp ->
-+          <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >>
-       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
-           <:class_str_item< method virtual private $l$ : $t$ >>
-       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
-@@ -1087,8 +1093,9 @@
-   ;
-   class_sig_item:
-     [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
--      | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
--          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
-+      | "val"; mf = OPT "mutable"; vf = OPT "virtual";
-+        l = label; ":"; t = ctyp ->
-+          <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
-       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
-           <:class_sig_item< method virtual private $l$ : $t$ >>
-       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
-Index: camlp4/etc/pr_o.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v
-retrieving revision 1.51
-diff -u -r1.51 pr_o.ml
---- camlp4/etc/pr_o.ml	5 Jan 2006 10:44:29 -0000	1.51
-+++ camlp4/etc/pr_o.ml	5 Apr 2006 02:26:01 -0000
-@@ -1768,10 +1768,11 @@
-                   [: `S LR "method"; private_flag pf; `label lab;
-                      `S LR ":" :];
-                `ctyp t "" k :]
--      | MLast.CgVal _ lab mf t ->
-+      | MLast.CgVal _ lab mf vf t ->
-           fun curr next dg k ->
-             [: `HVbox
--                  [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
-+                  [: `S LR "val"; mutable_flag mf; virtual_flag vf;
-+                     `label lab; `S LR ":" :];
-                `ctyp t "" k :]
-       | MLast.CgVir _ lab pf t ->
-           fun curr next dg k ->
-Index: camlp4/meta/pa_r.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v
-retrieving revision 1.64
-diff -u -r1.64 pa_r.ml
---- camlp4/meta/pa_r.ml	29 Jun 2005 04:11:26 -0000	1.64
-+++ camlp4/meta/pa_r.ml	5 Apr 2006 02:26:01 -0000
-@@ -658,7 +658,9 @@
-       | "inherit"; ce = class_expr; pb = OPT as_lident ->
-           <:class_str_item< inherit $ce$ $opt:pb$ >>
-       | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
--          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> 
-+      | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
-+          <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >>
-       | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-           <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
-       | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
-@@ -701,8 +703,9 @@
-     [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
-           <:class_sig_item< declare $list:st$ end >>
-       | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
--      | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
--          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
-+      | "value"; mf = OPT "mutable"; vf = OPT "virtual";
-+        l = label; ":"; t = ctyp ->
-+          <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
-       | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-           <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
-       | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-Index: camlp4/meta/q_MLast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v
-retrieving revision 1.60
-diff -u -r1.60 q_MLast.ml
---- camlp4/meta/q_MLast.ml	29 Jun 2005 04:11:26 -0000	1.60
-+++ camlp4/meta/q_MLast.ml	5 Apr 2006 02:26:01 -0000
-@@ -947,6 +947,8 @@
-           Qast.Node "CrDcl" [Qast.Loc; st]
-       | "inherit"; ce = class_expr; pb = SOPT as_lident ->
-           Qast.Node "CrInh" [Qast.Loc; ce; pb]
-+      | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
-+          Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t]
-       | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
-           Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
-       | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-@@ -992,8 +994,9 @@
-     [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
-           Qast.Node "CgDcl" [Qast.Loc; st]
-       | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
--      | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
--          Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
-+      | "value"; mf = SOPT "mutable"; vf = SOPT "virtual";
-+        l = label; ":"; t = ctyp ->
-+          Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t]
-       | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-           Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
-       | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-Index: camlp4/ocaml_src/camlp4/ast2pt.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v
-retrieving revision 1.36
-diff -u -r1.36 ast2pt.ml
---- camlp4/ocaml_src/camlp4/ast2pt.ml	29 Jun 2005 04:11:26 -0000	1.36
-+++ camlp4/ocaml_src/camlp4/ast2pt.ml	5 Apr 2006 02:26:01 -0000
-@@ -227,6 +227,7 @@
- ;;
- let mkmutable m = if m then Mutable else Immutable;;
- let mkprivate m = if m then Private else Public;;
-+let mkvirtual m = if m then Virtual else Concrete;;
- let mktrecord (loc, n, m, t) =
-   n, mkmutable m, ctyp (mkpolytype t), mkloc loc
- ;;
-@@ -878,8 +879,8 @@
-   | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
-   | CgMth (loc, s, pf, t) ->
-       Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
--  | CgVal (loc, s, b, t) ->
--      Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
-+  | CgVal (loc, s, b, v, t) ->
-+      Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l
-   | CgVir (loc, s, b, t) ->
-       Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
- and class_expr =
-@@ -923,6 +924,8 @@
-   | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
-   | CrVir (loc, s, b, t) ->
-       Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
-+  | CrVvr (loc, s, b, t) ->
-+      Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l
- ;;
- 
- let interf ast = List.fold_right sig_item ast [];;
-Index: camlp4/ocaml_src/camlp4/mLast.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v
-retrieving revision 1.20
-diff -u -r1.20 mLast.mli
---- camlp4/ocaml_src/camlp4/mLast.mli	29 Jun 2005 04:11:26 -0000	1.20
-+++ camlp4/ocaml_src/camlp4/mLast.mli	5 Apr 2006 02:26:01 -0000
-@@ -180,7 +180,7 @@
-   | CgDcl of loc * class_sig_item list
-   | CgInh of loc * class_type
-   | CgMth of loc * string * bool * ctyp
--  | CgVal of loc * string * bool * ctyp
-+  | CgVal of loc * string * bool * bool * ctyp
-   | CgVir of loc * string * bool * ctyp
- and class_expr =
-     CeApp of loc * class_expr * expr
-@@ -197,6 +197,7 @@
-   | CrMth of loc * string * bool * expr * ctyp option
-   | CrVal of loc * string * bool * expr
-   | CrVir of loc * string * bool * ctyp
-+  | CrVvr of loc * string * bool * ctyp
- ;;
- 
- external loc_of_ctyp : ctyp -> loc = "%field0";;
-Index: camlp4/ocaml_src/camlp4/reloc.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v
-retrieving revision 1.20
-diff -u -r1.20 reloc.ml
---- camlp4/ocaml_src/camlp4/reloc.ml	29 Jun 2005 04:11:26 -0000	1.20
-+++ camlp4/ocaml_src/camlp4/reloc.ml	5 Apr 2006 02:26:01 -0000
-@@ -430,8 +430,8 @@
-         let nloc = floc loc in CgInh (nloc, class_type floc sh x1)
-     | CgMth (loc, x1, x2, x3) ->
-         let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3)
--    | CgVal (loc, x1, x2, x3) ->
--        let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3)
-+    | CgVal (loc, x1, x2, x3, x4) ->
-+        let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4)
-     | CgVir (loc, x1, x2, x3) ->
-         let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3)
-   in
-@@ -478,6 +478,8 @@
-         let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3)
-     | CrVir (loc, x1, x2, x3) ->
-         let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3)
-+    | CrVvr (loc, x1, x2, x3) ->
-+        let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3)
-   in
-   self
- ;;
-Index: camlp4/ocaml_src/meta/pa_r.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v
-retrieving revision 1.59
-diff -u -r1.59 pa_r.ml
---- camlp4/ocaml_src/meta/pa_r.ml	29 Jun 2005 04:11:26 -0000	1.59
-+++ camlp4/ocaml_src/meta/pa_r.ml	5 Apr 2006 02:26:01 -0000
-@@ -2161,6 +2161,15 @@
-         (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
-            (_loc : Lexing.position * Lexing.position) ->
-            (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
-+      [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
-+       Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-+       Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-+       Gramext.Stoken ("", ":");
-+       Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-+      Gramext.action
-+        (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _
-+           (_loc : Lexing.position * Lexing.position) ->
-+           (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item));
-       [Gramext.Stoken ("", "value");
-        Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-        Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-@@ -2338,13 +2347,15 @@
-            (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
-       [Gramext.Stoken ("", "value");
-        Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-+       Gramext.Sopt (Gramext.Stoken ("", "virtual"));
-        Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-        Gramext.Stoken ("", ":");
-        Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-       Gramext.action
--        (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
-+        (fun (t : 'ctyp) _ (l : 'label) (vf : string option)
-+           (mf : string option) _
-            (_loc : Lexing.position * Lexing.position) ->
--           (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
-+           (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item));
-       [Gramext.Stoken ("", "inherit");
-        Gramext.Snterm
-          (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
-Index: camlp4/ocaml_src/meta/q_MLast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v
-retrieving revision 1.65
-diff -u -r1.65 q_MLast.ml
---- camlp4/ocaml_src/meta/q_MLast.ml	12 Jan 2006 08:54:21 -0000	1.65
-+++ camlp4/ocaml_src/meta/q_MLast.ml	5 Apr 2006 02:26:01 -0000
-@@ -3152,9 +3152,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__17))])],
-+                      (Qast.Str x : 'e__18))])],
-           Gramext.action
--            (fun (a : 'e__17 option)
-+            (fun (a : 'e__18 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3191,9 +3191,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__16))])],
-+                      (Qast.Str x : 'e__17))])],
-           Gramext.action
--            (fun (a : 'e__16 option)
-+            (fun (a : 'e__17 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3216,9 +3216,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__15))])],
-+                      (Qast.Str x : 'e__16))])],
-           Gramext.action
--            (fun (a : 'e__15 option)
-+            (fun (a : 'e__16 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3235,6 +3235,31 @@
-            (_loc : Lexing.position * Lexing.position) ->
-            (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
-             'class_str_item));
-+      [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
-+       Gramext.srules
-+         [[Gramext.Sopt
-+             (Gramext.srules
-+                [[Gramext.Stoken ("", "mutable")],
-+                 Gramext.action
-+                   (fun (x : string)
-+                      (_loc : Lexing.position * Lexing.position) ->
-+                      (Qast.Str x : 'e__15))])],
-+          Gramext.action
-+            (fun (a : 'e__15 option)
-+               (_loc : Lexing.position * Lexing.position) ->
-+               (Qast.Option a : 'a_opt));
-+          [Gramext.Snterm
-+             (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
-+          Gramext.action
-+            (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
-+               (a : 'a_opt))];
-+       Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-+       Gramext.Stoken ("", ":");
-+       Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-+      Gramext.action
-+        (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _
-+           (_loc : Lexing.position * Lexing.position) ->
-+           (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item));
-       [Gramext.Stoken ("", "inherit");
-        Gramext.Snterm
-          (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
-@@ -3366,9 +3391,9 @@
-                  Gramext.action
-                    (fun _ (csf : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (csf : 'e__18))])],
-+                      (csf : 'e__19))])],
-           Gramext.action
--            (fun (a : 'e__18 list)
-+            (fun (a : 'e__19 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -3446,9 +3471,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__22))])],
-+                      (Qast.Str x : 'e__24))])],
-           Gramext.action
--            (fun (a : 'e__22 option)
-+            (fun (a : 'e__24 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3471,9 +3496,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__21))])],
-+                      (Qast.Str x : 'e__23))])],
-           Gramext.action
--            (fun (a : 'e__21 option)
-+            (fun (a : 'e__23 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3496,9 +3521,26 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__20))])],
-+                      (Qast.Str x : 'e__21))])],
-           Gramext.action
--            (fun (a : 'e__20 option)
-+            (fun (a : 'e__21 option)
-+               (_loc : Lexing.position * Lexing.position) ->
-+               (Qast.Option a : 'a_opt));
-+          [Gramext.Snterm
-+             (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
-+          Gramext.action
-+            (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
-+               (a : 'a_opt))];
-+       Gramext.srules
-+         [[Gramext.Sopt
-+             (Gramext.srules
-+                [[Gramext.Stoken ("", "virtual")],
-+                 Gramext.action
-+                   (fun (x : string)
-+                      (_loc : Lexing.position * Lexing.position) ->
-+                      (Qast.Str x : 'e__22))])],
-+          Gramext.action
-+            (fun (a : 'e__22 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3510,9 +3552,10 @@
-        Gramext.Stoken ("", ":");
-        Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-       Gramext.action
--        (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
-+        (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _
-            (_loc : Lexing.position * Lexing.position) ->
--           (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
-+           (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) :
-+            'class_sig_item));
-       [Gramext.Stoken ("", "inherit");
-        Gramext.Snterm
-          (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
-@@ -3531,9 +3574,9 @@
-                  Gramext.action
-                    (fun _ (s : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (s : 'e__19))])],
-+                      (s : 'e__20))])],
-           Gramext.action
--            (fun (a : 'e__19 list)
-+            (fun (a : 'e__20 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -3556,9 +3599,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__23))])],
-+                      (Qast.Str x : 'e__25))])],
-           Gramext.action
--            (fun (a : 'e__23 option)
-+            (fun (a : 'e__25 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3593,9 +3636,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__24))])],
-+                      (Qast.Str x : 'e__26))])],
-           Gramext.action
--            (fun (a : 'e__24 option)
-+            (fun (a : 'e__26 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3713,9 +3756,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__25))])],
-+                      (Qast.Str x : 'e__27))])],
-           Gramext.action
--            (fun (a : 'e__25 option)
-+            (fun (a : 'e__27 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3922,9 +3965,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__26))])],
-+                      (Qast.Str x : 'e__28))])],
-           Gramext.action
--            (fun (a : 'e__26 option)
-+            (fun (a : 'e__28 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -4390,9 +4433,9 @@
-                  Gramext.action
-                    (fun _ (e : 'expr)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (e : 'e__29))])],
-+                      (e : 'e__31))])],
-           Gramext.action
--            (fun (a : 'e__29 list)
-+            (fun (a : 'e__31 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4425,9 +4468,9 @@
-                  Gramext.action
-                    (fun _ (e : 'expr)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (e : 'e__28))])],
-+                      (e : 'e__30))])],
-           Gramext.action
--            (fun (a : 'e__28 list)
-+            (fun (a : 'e__30 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4454,9 +4497,9 @@
-                  Gramext.action
-                    (fun _ (e : 'expr)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (e : 'e__27))])],
-+                      (e : 'e__29))])],
-           Gramext.action
--            (fun (a : 'e__27 list)
-+            (fun (a : 'e__29 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4547,9 +4590,9 @@
-                  Gramext.action
-                    (fun _ (cf : 'class_str_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (cf : 'e__30))])],
-+                      (cf : 'e__32))])],
-           Gramext.action
--            (fun (a : 'e__30 list)
-+            (fun (a : 'e__32 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4592,9 +4635,9 @@
-                  Gramext.action
-                    (fun _ (csf : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (csf : 'e__32))])],
-+                      (csf : 'e__34))])],
-           Gramext.action
--            (fun (a : 'e__32 list)
-+            (fun (a : 'e__34 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4623,9 +4666,9 @@
-                  Gramext.action
-                    (fun _ (csf : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (csf : 'e__31))])],
-+                      (csf : 'e__33))])],
-           Gramext.action
--            (fun (a : 'e__31 list)
-+            (fun (a : 'e__33 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-Index: camlp4/top/rprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v
-retrieving revision 1.18
-diff -u -r1.18 rprint.ml
---- camlp4/top/rprint.ml	29 Jun 2005 04:11:26 -0000	1.18
-+++ camlp4/top/rprint.ml	5 Apr 2006 02:26:01 -0000
-@@ -288,8 +288,9 @@
-       fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
-         (if priv then "private " else "") (if virt then "virtual " else "")
-         name Toploop.print_out_type.val ty
--  | Ocsg_value name mut ty ->
--      fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
-+  | Ocsg_value name mut virt ty ->
-+      fprintf ppf "@[<2>value %s%s%s :@ %a;@]"
-+        (if mut then "mutable " else "") (if virt then "virtual " else "")
-         name Toploop.print_out_type.val ty ]
- ;
- 
diff --git a/testlabl/varunion.ml b/testlabl/varunion.ml
deleted file mode 100644
index 30a410f2..00000000
--- a/testlabl/varunion.ml
+++ /dev/null
@@ -1,435 +0,0 @@
-(* cvs update -r varunion parsing typing bytecomp toplevel *)
-
-type t = private [> ];;
-type u = private [> ] ~ [t];;
-type v = [t | u];;
-let f x = (x : t :> v);;
-
-(* bad *)
-module Mix(X: sig type t = private [> ] end)
-    (Y: sig type t = private [> ] end) =
-  struct type t = [X.t | Y.t] end;;
-
-(* bad *)
-module Mix(X: sig type t = private [> `A of int ] end)
-    (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
-
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] end)
-    (Y: sig type t = private [> `A of int] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
-
-(* bad *)
-module Mix(X: sig type t = private [> `A of int ] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
-
-type 'a t = private [> `L of 'a] ~ [`L];;
-
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
-
-module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct
-    type t = [X.t | Y.t]
-    let which = function #X.t -> `X | #Y.t -> `Y
-  end;;
-
-module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
-    (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
-    (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
-  struct
-    type t = [X.t | Y.t]
-    let which = function #X.t -> `X | #Y.t -> `Y
-  end;;
-
-(* ok *)
-module M =
-  Mix(struct type t = [`C of char] end)
-    (struct type t = [`A of int | `C of char] end)
-    (struct type t = [`B of bool | `C of char] end);;
-
-(* bad *)
-module M =
-  Mix(struct type t = [`B of bool] end)
-    (struct type t = [`A of int | `B of bool] end)
-    (struct type t = [`B of bool | `C of char] end);;
-
-(* ok *)
-module M1 = struct type t = [`A of int | `C of char] end
-module M2 = struct type t = [`B of bool | `C of char] end
-module I = struct type t = [`C of char] end
-module M = Mix(I)(M1)(M2) ;;
-
-let c = (`C 'c' : M.t) ;;
-
-module M(X : sig type t = private [> `A] end) = 
-  struct let f (#X.t as x) = x end;;
-
-(* code generation *)
-type t = private [> `A ] ~ [`B];;
-match `B with #t -> 1 | `B -> 2;;
-
-module M : sig type t = private [> `A of int | `B] ~ [`C] end =
-  struct type t = [`A of int | `B | `D of bool] end;;
-let f = function (`C | #M.t) -> 1+1 ;;
-let f = function (`A _ | `B #M.t) -> 1+1 ;;
-
-(* expression *)
-module Mix(X:sig type t = private [> ] val show: t -> string end)
-    (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
-  struct
-    type t = [X.t | Y.t]
-    let show : t -> string = function
-        #X.t as x -> X.show x
-      | #Y.t as y -> Y.show y
-  end;;
-
-module EStr = struct
-  type t = [`Str of string]
-  let show (`Str s) = s
-end
-module EInt = struct
-  type t = [`Int of int]
-  let show (`Int i) = string_of_int i
-end
-module M = Mix(EStr)(EInt);;
-
-module type T = sig type t = private [> ] val show: t -> string end
-module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
-    T with type t = [X.t | Y.t] =
-  struct
-    type t = [X.t | Y.t]
-    let show = function
-        #X.t as x -> X.show x
-      | #Y.t as y -> Y.show y
-  end;;
-module M = Mix(EStr)(EInt);;
-
-(* deep *)
-module M : sig type t = private [> `A] end = struct type t = [`A] end
-module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
-
-(* bad *)
-type t = private [> ]
-type u = private [> `A of int] ~ [t] ;;
-
-(* ok *)
-type t = private [> `A of int]
-type u = private [> `A of int] ~ [t] ;;
-
-module F(X: sig
-  type t = private [> ] ~ [`A;`B;`C;`D]
-  type u = private [> `A|`B|`C] ~ [t; `D]
-end) : sig type v = private [< X.t | X.u | `D] end = struct
-  open X
-  let f = function #u -> 1 | #t -> 2 | `D -> 3
-  let g = function #u|#t|`D -> 2 
-  type v = [t|u|`D]
-end
-
-(* ok *)
-module M = struct type t = private [> `A] end;;
-module M' : sig type t = private [> ] ~ [`A] end = M;;
-
-(* ok *)
-module type T = sig type t = private [> ] ~ [`A] end;;
-module type T' = T with type t = private [> `A];;
-
-(* ok *)
-type t = private [> ] ~ [`A]
-let f = function `A x -> x | #t -> 0
-type t' = private [< `A of int | t];;
-
-(* should be ok *)
-module F(X:sig end) :
-    sig type t = private [> ] type u = private [> ] ~ [t] end =
-  struct type t = [ `A] type u = [`B] end
-module M = F(String)
-let f = function #M.t -> 1 | #M.u -> 2
-let f = function #M.t -> 1 | _ -> 2
-type t = [M.t | M.u]
-let f = function #t -> 1 | _ -> 2;;
-module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
-  struct let f = function #X.t -> 1 | _ -> 2 end;;
-module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
-module M1 = G(struct type t = M.t type u = M.u end) ;;
-(* bad *)
-let f = function #F(String).t -> 1 | _ -> 2;;
-type t = [F(String).t | M.u]
-let f = function #t -> 1 | _ -> 2;;
-module N : sig type t = private [> ] end =
-  struct type t = [F(String).t | M.u] end;;
-
-(* compatibility improvement *)
-type a = [`A of int | `B]
-type b = [`A of bool | `B]
-type c = private [> ] ~ [a;b]
-let f = function #c -> 1 | `A x -> truncate x
-type d = private [> ] ~ [a]
-let g = function #d -> 1 | `A x -> truncate x;;
-
-
-(* Expression Problem: functorial form *)
-
-type num = [ `Num of int ]
-
-module type Exp = sig
-  type t = private [> num]
-  val eval : t -> t
-  val show : t -> string
-end
-
-module Num(X : Exp) = struct
-  type t = num
-  let eval (`Num _ as x) : X.t = x
-  let show (`Num n) = string_of_int n
-end
-
-type 'a add = [ `Add of 'a * 'a ]
-
-module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
-  type t = X.t add
-  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
-  let eval (`Add(e1, e2) : t) =
-    let e1 = X.eval e1 and e2 = X.eval e2 in
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1+n2)
-    | `Num 0, e | e, `Num 0 -> e
-    | e12 -> `Add e12
-end 
-
-type 'a mul = [`Mul of 'a * 'a]
-
-module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
-  type t = X.t mul
-  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
-  let eval (`Mul(e1, e2) : t) =
-    let e1 = X.eval e1 and e2 = X.eval e2 in
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1*n2)
-    | `Num 0, e | e, `Num 0 -> `Num 0
-    | `Num 1, e | e, `Num 1 -> e
-    | e12 -> `Mul e12
-end
-
-module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
-  module type S =
-    sig
-      type t = private [> ] ~ [ X.t ]
-      val eval : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Dummy = struct type t = [`Dummy] end
-
-module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
-  struct
-    type t = [E1.t | E2.t]
-    let eval = function
-        #E1.t as x -> E1.eval x
-      | #E2.t as x -> E2.eval x
-    let show = function
-        #E1.t as x -> E1.show x
-      | #E2.t as x -> E2.show x
-  end
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
-    Mix(EAdd)(Num(EAdd))(Add(EAdd))
-
-(* A bit heavy: one must pass E to everybody *)
-module rec E : Exp with type t = [num | E.t add | E.t mul] =
-    Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
-
-let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
-
-(* Alternatives *)
-(* Direct approach, no need of Mix *)
-module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
-  struct
-    module E1 = Num(E)
-    module E2 = Add(E)
-    module E3 = Mul(E)
-    type t = E.t
-    let show = function
-      | #num as x -> E1.show x
-      | #add as x -> E2.show x
-      | #mul as x -> E3.show x
-    let eval = function
-      | #num as x -> E1.eval x
-      | #add as x -> E2.eval x
-      | #mul as x -> E3.eval x
-  end
-
-(* Do functor applications in Mix *)
-module type T = sig type t = private [> ] end
-module type Tnum = sig type t = private [> num] end
-
-module Ext(E : Tnum) = struct
-  module type S = functor (Y : Exp with type t = E.t) ->
-    sig
-      type t = private [> num]
-      val eval : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Ext'(E : Tnum)(X : T) = struct
-  module type S = functor (Y : Exp with type t = E.t) ->
-    sig
-      type t = private [> ] ~ [ X.t ]
-      val eval : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
-  struct
-    module E1 = F1(E)
-    module E2 = F2(E)
-    type t = [E1.t | E2.t]
-    let eval = function
-        #E1.t as x -> E1.eval x
-      | #E2.t as x -> E2.eval x
-    let show = function
-        #E1.t as x -> E1.show x
-      | #E2.t as x -> E2.show x
-  end
-
-module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
-    (E' : Exp with type t = E.t) =
-  Mix(E)(F1)(F2)
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
-  Mix(EAdd)(Num)(Add)
-
-module rec EMul : (Exp with type t = [num | EMul.t mul]) =
-  Mix(EMul)(Num)(Mul)
-
-module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
-  Mix(E)(Join(E)(Num)(Add))(Mul)
-
-(* Linear extension by the end: not so nice *)
-module LExt(X : T) = struct
-  module type S =
-    sig
-      type t
-      val eval : t -> X.t
-      val show : t -> string
-    end
-end
-module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
-  struct
-    type t = [num | X.t]
-    let show = function
-        `Num n -> string_of_int n
-      | #X.t as x -> X.show x
-    let eval = function
-        #num as x -> x
-      | #X.t as x -> X.eval x
-  end
-module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
-    (X : LExt(E).S with type t = private [> ] ~ [add]) =
-  struct
-    type t = [E.t add | X.t]
-    let show = function
-        `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
-      | #X.t as x -> X.show x
-    let eval = function
-        `Add(e1,e2) ->
-          let e1 = E.eval e1 and e2 = E.eval e2 in
-          begin match e1, e2 with
-            `Num n1, `Num n2 -> `Num (n1+n2)
-          | `Num 0, e | e, `Num 0 -> e
-          | e12 -> `Add e12
-          end
-      | #X.t as x -> X.eval x
-  end
-module LEnd = struct
-  type t = [`Dummy]
-  let show `Dummy = ""
-  let eval `Dummy = `Dummy
-end
-module rec L : Exp with type t = [num | L.t add | `Dummy] =
-    LAdd(L)(LNum(L)(LEnd))
-
-(* Back to first form, but add map *)
-
-module Num(X : Exp) = struct
-  type t = num
-  let map f x = x
-  let eval1 (`Num _ as x) : X.t = x
-  let show (`Num n) = string_of_int n
-end
-
-module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
-  type t = X.t add
-  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
-  let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
-  let eval1 (`Add(e1, e2) as e : t) =
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1+n2)
-    | `Num 0, e | e, `Num 0 -> e
-    | _ -> e
-end 
-
-module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
-  type t = X.t mul
-  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
-  let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
-  let eval1 (`Mul(e1, e2) as e : t) =
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1*n2)
-    | `Num 0, e | e, `Num 0 -> `Num 0
-    | `Num 1, e | e, `Num 1 -> e
-    | _ -> e
-end
-
-module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
-  module type S =
-    sig
-      type t = private [> ] ~ [ X.t ]
-      val map  : (Y.t -> Y.t) -> t -> t
-      val eval1 : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
-  struct
-    type t = [E1.t | E2.t]
-    let map f = function
-        #E1.t as x -> (E1.map f x : E1.t :> t)
-      | #E2.t as x -> (E2.map f x : E2.t :> t)
-    let eval1 = function
-        #E1.t as x -> E1.eval1 x
-      | #E2.t as x -> E2.eval1 x
-    let show = function
-        #E1.t as x -> E1.show x
-      | #E2.t as x -> E2.show x
-  end
-
-module type ET = sig
-  type t
-  val map  : (t -> t) -> t -> t
-  val eval1 : t -> t
-  val show : t -> string
-end
-
-module Fin(E : ET) = struct
-  include E
-  let rec eval e = eval1 (map eval e)
-end
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
-    Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
-
-module rec E : Exp with type t = [num | E.t add | E.t mul] =
-    Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
-
-let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
diff --git a/testsuite/.ignore b/testsuite/.ignore
new file mode 100644
index 00000000..a333a8b0
--- /dev/null
+++ b/testsuite/.ignore
@@ -0,0 +1 @@
+_log
diff --git a/testsuite/.svnignore b/testsuite/.svnignore
deleted file mode 100644
index 93feea3b..00000000
--- a/testsuite/.svnignore
+++ /dev/null
@@ -1,9 +0,0 @@
-# svn propset -R svn:ignore -F .svnignore .
-# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done
-_log
-*.so
-*.a
-*.result
-*.byte
-*.native
-program
diff --git a/testsuite/Makefile b/testsuite/Makefile
index d7a97569..497d7403 100644
--- a/testsuite/Makefile
+++ b/testsuite/Makefile
@@ -5,12 +5,13 @@ NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-pr
 
 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 "  lib           builds library modules"
-	@echo "  clean         deletes generated files"
-	@echo "  report        prints the report for the last execution, if any"
+	@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"
 
 all: lib
 	@for dir in tests/*; do \
@@ -32,23 +33,29 @@ one: lib
 	@$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR)
 
 exec-one:
-	@echo "Running tests from '$$DIR' ..."
-	@(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) && cd ../..)
+	@if [ ! -f $(DIR)/Makefile ]; then \
+	  for dir in $(DIR)/*; do \
+	    if [ -d $$dir ]; then \
+	      $(MAKE) exec-one DIR=$$dir; \
+	    fi; \
+	  done; \
+        else \
+	  echo "Running tests from '$$DIR' ..."; \
+	  (cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR)); \
+	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)
 
 lib: FORCE
-	@(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR) && cd ..)
+	@(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR))
 
 clean: FORCE
-	@(cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean && cd ..)
-	@for file in tests/*; do \
-	  if [ -d $$file ]; then \
-	    (cd $$file && $(MAKE) BASEDIR=$(BASEDIR) clean && cd ../..); \
-	  fi \
-	done
-	@for file in interactive/*; do \
-	  if [ -d $$file ]; then \
-	    (cd $$file && $(MAKE) BASEDIR=$(BASEDIR) clean && cd ../..); \
-	  fi \
+	@(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
@@ -59,6 +66,7 @@ report: FORCE
 	@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
 
diff --git a/testsuite/interactive/lib-gc/Makefile b/testsuite/interactive/lib-gc/Makefile
index 4eb07e7e..65bd44d1 100644
--- a/testsuite/interactive/lib-gc/Makefile
+++ b/testsuite/interactive/lib-gc/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 default:
 	@$(OCAMLC) -o program.byte alloc.ml
 	@./program.byte
@@ -7,4 +9,4 @@ default:
 clean: defaultclean
 	@rm -fr program.*
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml
index ea103e42..dbcb3e4f 100644
--- a/testsuite/interactive/lib-gc/alloc.ml
+++ b/testsuite/interactive/lib-gc/alloc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/interactive/lib-graph-2/Makefile b/testsuite/interactive/lib-graph-2/Makefile
index 6ede5e50..9a5c0c5f 100644
--- a/testsuite/interactive/lib-graph-2/Makefile
+++ b/testsuite/interactive/lib-graph-2/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=graph_test
 #ADD_COMPFLAGS=
 LIBRARIES=graphics
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-graph-2/graph_test.ml b/testsuite/interactive/lib-graph-2/graph_test.ml
index 217e2fa5..6c9fd49a 100644
--- a/testsuite/interactive/lib-graph-2/graph_test.ml
+++ b/testsuite/interactive/lib-graph-2/graph_test.ml
@@ -1,13 +1,12 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, 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 GNU Library General Public License, with    *)
-(*  the special exception on linking described in file ../../LICENSE.  *)
+(*  under the terms of the Q Public License version 1.0.               *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -28,7 +27,7 @@ let sz = 450;;
 
 open_graph (Printf.sprintf " %ix%i" sz sz);;
 
-(* To be defined for older versions of O'Caml
+(* To be defined for older versions of OCaml
    Lineto, moveto and draw_rect.
 
 let rlineto x y =
@@ -151,7 +150,7 @@ let x,y = current_point () in
 fill_rect x (y - 5) (8 * 20) 25;;
 set_color yellow;;
 go_legend ();;
-draw_string "Graphics (Caml)";;
+draw_string "Graphics (OCaml)";;
 
 (* Pie parts in different colors. *)
 let draw_green_string s = set_color green; draw_string s;;
diff --git a/testsuite/interactive/lib-graph-3/Makefile b/testsuite/interactive/lib-graph-3/Makefile
index a37aa33d..6f0660a9 100644
--- a/testsuite/interactive/lib-graph-3/Makefile
+++ b/testsuite/interactive/lib-graph-3/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=sorts
 ADD_COMPFLAGS=-thread
 LIBRARIES=unix threads graphics
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-graph/Makefile b/testsuite/interactive/lib-graph/Makefile
index be825658..61f472b3 100644
--- a/testsuite/interactive/lib-graph/Makefile
+++ b/testsuite/interactive/lib-graph/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=graph_example
 #ADD_COMPFLAGS=
 LIBRARIES=graphics
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/interactive/lib-signals/Makefile b/testsuite/interactive/lib-signals/Makefile
index 445f9ac7..ec22e068 100644
--- a/testsuite/interactive/lib-signals/Makefile
+++ b/testsuite/interactive/lib-signals/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 default:
 	@$(OCAMLC) -o program.byte signals.ml
 	@./program.byte
@@ -7,4 +9,4 @@ default:
 clean: defaultclean
 	@rm -fr program.*
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/lib/Makefile b/testsuite/lib/Makefile
index 52b50207..b6fc63c2 100644
--- a/testsuite/lib/Makefile
+++ b/testsuite/lib/Makefile
@@ -1,7 +1,14 @@
 # $Id$
 
-compile: testing.cmi testing.cmo testing.cmx
+compile: compile-targets
+
+promote: defaultpromote
 
 clean: defaultclean
 
 include ../makefiles/Makefile.common
+
+compile-targets: testing.cmi testing.cmo
+	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	  $(MAKE) testing.cmx; \
+	fi
diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml
index 2015aa14..aa8933a7 100644
--- a/testsuite/lib/testing.ml
+++ b/testsuite/lib/testing.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/lib/testing.mli b/testsuite/lib/testing.mli
index 6f47d2a3..18b2ea03 100644
--- a/testsuite/lib/testing.mli
+++ b/testsuite/lib/testing.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
index a1abd1aa..983f82c2 100644
--- a/testsuite/makefiles/Makefile.common
+++ b/testsuite/makefiles/Makefile.common
@@ -4,21 +4,28 @@ TOPDIR=$(BASEDIR)/..
 
 include $(TOPDIR)/config/Makefile
 
+DIFF=diff -q
 BOOTDIR=$(TOPDIR)/boot
 OCAMLRUN=$(BOOTDIR)/ocamlrun$(EXE)
-OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml$(EXE)
-OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc$(EXE)
-OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt$(EXE)
+OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml$(EXE) -I $(TOPDIR)/stdlib
+OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc$(EXE) -I $(TOPDIR)/stdlib
+OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt$(EXE) -I $(TOPDIR)/stdlib
 OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc$(EXE)
 OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex$(EXE)
 OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib$(EXE)
 OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
 OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native
 DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj$(EXE)
+BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi`
 #COMPFLAGS=
 #FORTRAN_COMPILER=
 #FORTRAN_LIBRARY=
 
+defaultpromote:
+	@for file in *.reference; do \
+	  cp `basename $$file reference`result $$file; \
+	done
+
 defaultclean:
 	@rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A)
 	@for dsym in *.dSYM; do \
diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad
index 833cfab3..9016dab3 100644
--- a/testsuite/makefiles/Makefile.okbad
+++ b/testsuite/makefiles/Makefile.okbad
@@ -10,10 +10,12 @@ compile:
 	  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 -q `basename $$file ml`reference `basename $$file ml`result || (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"; \
 	  fi; \
 	done
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f ./a.out *.cm* *.result
diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one
index 4921d7df..ca07bf16 100644
--- a/testsuite/makefiles/Makefile.one
+++ b/testsuite/makefiles/Makefile.one
@@ -25,16 +25,22 @@ compile: $(ML_FILES) $(CMO_FILES) $(CMX_FILES) $(MAIN_MODULE).cmo $(MAIN_MODULE)
 	  $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \
 	done;
 	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo
-	@$(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx
+	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	  $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \
+	fi
 
 run:
 	@printf " ... testing with ocamlc"
 	@./program.byte $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1)
-	@diff -q $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1)
-	@printf " ocamlopt"
-	@./program.native $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1)
-	@diff -q $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (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"
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.result ./program.* $(GENERATED_SOURCES) $(O_FILES)
diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
index 09925132..e5bd430a 100644
--- a/testsuite/makefiles/Makefile.several
+++ b/testsuite/makefiles/Makefile.several
@@ -26,11 +26,15 @@ run-all:
 	done;
 	@for file in *.ml; do \
 	  printf " ... testing '$$file':"; \
-	  $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) -w a $(CMA_FILES) -I ../../lib $(CMO_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
-	  $(MAKE) run-file DESC=ocamlopt COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) $(O_FILES) -w a $(CMXA_FILES) -I ../../lib $(CMX_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
+	  $(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 ../../li $(CMO_FILES)' FILE=$$file && \
-	    $(MAKE) run-file DESC=ocamlopt-unsafe COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='-w a -unsafe -I ../../lib $(CMX_FILES)' FILE=$$file; \
+	    $(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;
@@ -46,8 +50,10 @@ run-file:
 	@if [ -f `basename $(FILE) ml`checker ]; then \
 	  sh `basename $(FILE) ml`checker; \
 	else \
-	  diff -q `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null || (echo " => failed" && exit 1); \
+	  $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null || (echo " => failed" && exit 1); \
 	fi
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.result ./program
diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel
index 2302b196..532763f4 100644
--- a/testsuite/makefiles/Makefile.toplevel
+++ b/testsuite/makefiles/Makefile.toplevel
@@ -2,15 +2,17 @@
 
 default:
 	@for file in *.ml; do \
-	  $(OCAML) < $$file 2>&1 | grep -v '^        Objective Caml version' > $$file.result; \
+	  $(OCAML) < $$file 2>&1 | grep -v '^        OCaml version' > $$file.result; \
 	  if [ -f $$file.principal.reference ]; then \
-	    $(OCAML) -principal < $$file 2>&1 | grep -v '^        Objective Caml version' > $$file.principal.result; \
+	    $(OCAML) -principal < $$file 2>&1 | grep -v '^        OCaml version' > $$file.principal.result; \
 	  fi; \
 	done
 	@for file in *.reference; do \
 	  printf " ... testing '$$file':"; \
-	  diff -q $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \
+	  $(DIFF) $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \
 	done
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.result
diff --git a/testsuite/tests/asmcomp/.ignore b/testsuite/tests/asmcomp/.ignore
new file mode 100644
index 00000000..321dc061
--- /dev/null
+++ b/testsuite/tests/asmcomp/.ignore
@@ -0,0 +1,7 @@
+codegen
+parsecmm.ml
+parsecmm.mli
+lexcmm.ml
+*.s
+*.out
+*.out.dSYM
diff --git a/testsuite/tests/asmcomp/.svnignore b/testsuite/tests/asmcomp/.svnignore
deleted file mode 100755
index dcb3b20e..00000000
--- a/testsuite/tests/asmcomp/.svnignore
+++ /dev/null
@@ -1,17 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < unbind_ident id) $5;
-        {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true} }
+        {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true;
+         fun_dbg = Debuginfo.none} }
 ;
 params:
     oneparam params     { $1 :: $2 }
diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml
index 8c46888c..5aa2ea05 100644
--- a/testsuite/tests/asmcomp/parsecmmaux.ml
+++ b/testsuite/tests/asmcomp/parsecmmaux.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli
index 55899655..d488db1f 100644
--- a/testsuite/tests/asmcomp/parsecmmaux.mli
+++ b/testsuite/tests/asmcomp/parsecmmaux.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/power-aix.S b/testsuite/tests/asmcomp/power-aix.S
index 96ed2b92..0752100f 100644
--- a/testsuite/tests/asmcomp/power-aix.S
+++ b/testsuite/tests/asmcomp/power-aix.S
@@ -1,6 +1,6 @@
 #*********************************************************************
 #*                                                                   *
-#*                          Objective Caml                           *
+#*                               OCaml                               *
 #*                                                                   *
 #*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        *
 #*                                                                   *
@@ -123,7 +123,7 @@
         .globl  .caml_c_call
 .caml_c_call:
 # Preserve RTOC and return address in callee-save registers
-# The C function will preserve them, and the Caml code does not
+# The C function will preserve them, and the OCaml code does not
 # expect them to be preserved
 # Return address is in 25, RTOC is in 26
         mflr    25
diff --git a/testsuite/tests/asmcomp/power-elf.S b/testsuite/tests/asmcomp/power-elf.S
index 994a9fa7..7fee4aa1 100644
--- a/testsuite/tests/asmcomp/power-elf.S
+++ b/testsuite/tests/asmcomp/power-elf.S
@@ -1,6 +1,6 @@
 /*********************************************************************/
 /*                                                                   */
-/*                          Objective Caml                           */
+/*                               OCaml                               */
 /*                                                                   */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        */
 /*                                                                   */
diff --git a/testsuite/tests/asmcomp/power-rhapsody.S b/testsuite/tests/asmcomp/power-rhapsody.S
index b4561058..06788a8c 100644
--- a/testsuite/tests/asmcomp/power-rhapsody.S
+++ b/testsuite/tests/asmcomp/power-rhapsody.S
@@ -1,6 +1,6 @@
 /*********************************************************************/
 /*                                                                   */
-/*                          Objective Caml                           */
+/*                               OCaml                               */
 /*                                                                   */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        */
 /*                                                                   */
diff --git a/testsuite/tests/asmcomp/quicksort.cmm b/testsuite/tests/asmcomp/quicksort.cmm
index 4029da8d..21b1add5 100644
--- a/testsuite/tests/asmcomp/quicksort.cmm
+++ b/testsuite/tests/asmcomp/quicksort.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/quicksort2.cmm b/testsuite/tests/asmcomp/quicksort2.cmm
index eae9809a..08988573 100644
--- a/testsuite/tests/asmcomp/quicksort2.cmm
+++ b/testsuite/tests/asmcomp/quicksort2.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm
index 47ce64c0..af4d39fc 100644
--- a/testsuite/tests/asmcomp/soli.cmm
+++ b/testsuite/tests/asmcomp/soli.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S
index 9a829e17..5f83bf0f 100644
--- a/testsuite/tests/asmcomp/sparc.S
+++ b/testsuite/tests/asmcomp/sparc.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/testsuite/tests/asmcomp/tagged-fib.cmm b/testsuite/tests/asmcomp/tagged-fib.cmm
index e5e45b0f..5ee234d9 100644
--- a/testsuite/tests/asmcomp/tagged-fib.cmm
+++ b/testsuite/tests/asmcomp/tagged-fib.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm
index df46813e..6f756287 100644
--- a/testsuite/tests/asmcomp/tagged-integr.cmm
+++ b/testsuite/tests/asmcomp/tagged-integr.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/tagged-quicksort.cmm b/testsuite/tests/asmcomp/tagged-quicksort.cmm
index b519e5ce..73fca101 100644
--- a/testsuite/tests/asmcomp/tagged-quicksort.cmm
+++ b/testsuite/tests/asmcomp/tagged-quicksort.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/tagged-tak.cmm b/testsuite/tests/asmcomp/tagged-tak.cmm
index fe9e6eb0..2bda2238 100644
--- a/testsuite/tests/asmcomp/tagged-tak.cmm
+++ b/testsuite/tests/asmcomp/tagged-tak.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/asmcomp/tak.cmm b/testsuite/tests/asmcomp/tak.cmm
index cd61ec89..26bbd968 100644
--- a/testsuite/tests/asmcomp/tak.cmm
+++ b/testsuite/tests/asmcomp/tak.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile
index 68d042af..0d368bfc 100644
--- a/testsuite/tests/backtrace/Makefile
+++ b/testsuite/tests/backtrace/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 EXECNAME=./program
 
 run-all:
@@ -6,11 +7,13 @@ run-all:
 	  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 -q `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+	    $(DIFF) `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
 	  done; \
 	done
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.result $(EXECNAME)
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-float/Makefile b/testsuite/tests/basic-float/Makefile
index 627ed788..dbe9b4df 100644
--- a/testsuite/tests/basic-float/Makefile
+++ b/testsuite/tests/basic-float/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 MODULES=float_record
 MAIN_MODULE=tfloat_record
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-io-2/Makefile b/testsuite/tests/basic-io-2/Makefile
index 9a7d2ba0..a5829bd1 100644
--- a/testsuite/tests/basic-io-2/Makefile
+++ b/testsuite/tests/basic-io-2/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=io
 EXEC_ARGS=io.ml
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-io/Makefile b/testsuite/tests/basic-io/Makefile
index b0edfabb..ac99445b 100644
--- a/testsuite/tests/basic-io/Makefile
+++ b/testsuite/tests/basic-io/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=wc
 EXEC_ARGS=wc.ml
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-manyargs/Makefile b/testsuite/tests/basic-manyargs/Makefile
index ef8a4f54..d84fc9ba 100644
--- a/testsuite/tests/basic-manyargs/Makefile
+++ b/testsuite/tests/basic-manyargs/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=manyargs
 C_FILES=manyargsprim
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-more/Makefile b/testsuite/tests/basic-more/Makefile
index 18f9c9b2..329d67de 100644
--- a/testsuite/tests/basic-more/Makefile
+++ b/testsuite/tests/basic-more/Makefile
@@ -1,4 +1,5 @@
+BASEDIR=../..
 MODULES=testing
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml
index 150d4088..af0e3a2f 100644
--- a/testsuite/tests/basic-more/testrandom.ml
+++ b/testsuite/tests/basic-more/testrandom.ml
@@ -1,13 +1,12 @@
 open Random
 
-let _ = 
+let _ =
   for i = 0 to 20 do
-    print_float (float 1000.); print_char ' '
+    print_int (int 1000); print_char ' '
   done;
   print_newline ();  print_newline ();
   for i = 0 to 20 do
-    print_int (int 1000); print_char ' '
+    print_float (float 1000.); print_char ' '
   done
 
 let _ = exit 0
-
diff --git a/testsuite/tests/basic-more/testrandom.reference b/testsuite/tests/basic-more/testrandom.reference
index f063674d..366e682c 100644
--- a/testsuite/tests/basic-more/testrandom.reference
+++ b/testsuite/tests/basic-more/testrandom.reference
@@ -1,4 +1,4 @@
-270.251355065 597.822945853 287.052171181 625.315015859 241.029649126 559.742196387 932.074421229 756.637587326 360.006556146 987.177314953 190.217751234 758.516786217 59.8488223602 328.350439075 172.627051105 944.543207513 629.424106752 868.196647048 174.382120878 78.1259713643 34.3270777955 
+344 685 182 641 439 500 104 20 921 370 217 885 949 678 615 412 401 606 428 869 289 
 
-683 782 740 270 835 136 791 168 324 222 156 835 328 636 233 153 671 69 95 357 92 
+122.128067547 461.324792129 360.006556146 768.75882284 396.500946942 190.217751234 567.660068681 403.59226778 59.8488223602 363.816246826 764.705761642 172.627051105 481.861849093 399.173195422 629.424106752 391.547032203 676.701133948 174.382120878 994.425675487 585.00027757 34.3270777955 
 All tests succeeded.
diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
index d02cb290..77d30ac3 100644
--- a/testsuite/tests/basic-more/tformat.ml
+++ b/testsuite/tests/basic-more/tformat.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                            Objective Caml                             *)
+(*                                 OCaml                                 *)
 (*                                                                       *)
 (*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
 (*                                                                       *)
diff --git a/testsuite/tests/basic-multdef/Makefile b/testsuite/tests/basic-multdef/Makefile
index 79660b57..5ec6aff7 100644
--- a/testsuite/tests/basic-multdef/Makefile
+++ b/testsuite/tests/basic-multdef/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 MODULES=multdef
 MAIN_MODULE=usemultdef
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-private/Makefile b/testsuite/tests/basic-private/Makefile
index 99475d0f..06c5591c 100644
--- a/testsuite/tests/basic-private/Makefile
+++ b/testsuite/tests/basic-private/Makefile
@@ -1,5 +1,7 @@
+BASEDIR=../..
+
 MODULES=length
 MAIN_MODULE=tlength
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
index a226dd11..4ba0bffc 100644
--- a/testsuite/tests/basic/Makefile
+++ b/testsuite/tests/basic/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+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 bbe8be32..8dcf1166 100644
--- a/testsuite/tests/basic/arrays.ml
+++ b/testsuite/tests/basic/arrays.ml
@@ -46,7 +46,9 @@ let test2 () =
   if not (testcopy [|1.2;2.3;3.4;4.5|]) then
     print_string "Test2: failed on float array\n";
   if not (testcopy [|"un"; "deux"; "trois"|]) then
-    print_string "Test2: failed on string array\n"
+    print_string "Test2: failed on string array\n";
+  if not (testcopy (bigarray 42)) then
+    print_string "Test2: failed on big array\n"
 
 module AbstractFloat =
   (struct
@@ -79,8 +81,41 @@ let test3 () =
           AbstractFloat.to_float u.(2) = 3.0) then
     print_string "Test3: failed on u\n"
 
+let test4 () =
+  let a = bigarray 0 in
+  let b = Array.sub a 50 10 in
+  if b <> [| 50;51;52;53;54;55;56;57;58;59 |] then
+    print_string "Test4: failed\n"
+
+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
+    print_string "Test5: failed on float arrays\n"
+
+let test6 () =
+  let a = [| 0;1;2;3;4;5;6;7;8;9 |] in
+  let b = Array.concat [a;a;a;a;a;a;a;a;a;a] in
+  if not (Array.length b = 100 && b.(6) = 6 && b.(42) = 2 && b.(99) = 9) then
+    print_string "Test6: failed\n"
+
+let test7 () =
+  let a = Array.make 10 "a" in
+  let b = [| "b1"; "b2"; "b3" |] in
+  Array.blit b 0 a 5 3;
+  if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b2"; "b3"; "a"; "a"|]
+  || b <> [|"b1"; "b2"; "b3"|]
+  then print_string "Test7: failed(1)\n";
+  Array.blit a 5 a 6 4;
+  if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b1"; "b2"; "b3"; "a"|]
+  then print_string "Test7: failed(2)\n"
+
 let _ =
   test1();
   test2();
   test3();
+  test4();
+  test5();
+  test6();
+  test7();
   exit 0
diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml
index 19574a1a..6dd1773d 100644
--- a/testsuite/tests/basic/boxedints.ml
+++ b/testsuite/tests/basic/boxedints.ml
@@ -166,6 +166,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (div min_int (of_int (-1))) min_int;
 
     testing_function "mod";
     List.iter
@@ -181,6 +182,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (rem min_int (of_int (-1))) (of_int 0);
 
     testing_function "and";
     List.iter
@@ -400,6 +402,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (div min_int (of_int (-1))) min_int;
 
     testing_function "mod";
     List.iter
@@ -415,6 +418,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (rem min_int (of_int (-1))) (of_int 0);
 
     testing_function "and";
     List.iter
diff --git a/testsuite/tests/basic/boxedints.reference b/testsuite/tests/basic/boxedints.reference
index fe08bb2b..009390fa 100644
--- a/testsuite/tests/basic/boxedints.reference
+++ b/testsuite/tests/basic/boxedints.reference
@@ -16,9 +16,9 @@ sub
 mul
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
 div
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 mod
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 and
  1... 2... 3... 4... 5...
 or
@@ -55,9 +55,9 @@ sub
 mul
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
 div
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 mod
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 and
  1... 2... 3... 4... 5...
 or
@@ -90,9 +90,9 @@ sub
 mul
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
 div
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 mod
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 and
  1... 2... 3... 4... 5...
 or
diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
index c23f2d8c..ffbaa041 100644
--- a/testsuite/tests/basic/maps.ml
+++ b/testsuite/tests/basic/maps.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml
index 983145ee..f2fa158c 100644
--- a/testsuite/tests/basic/sets.ml
+++ b/testsuite/tests/basic/sets.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile
index 0cec7e63..a8905668 100644
--- a/testsuite/tests/callback/Makefile
+++ b/testsuite/tests/callback/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 CC=$(NATIVECC) -I $(TOPDIR)/byterun
 
 default: run-byte run-opt
@@ -10,18 +12,22 @@ run-byte: common
 	@$(OCAMLC) -c tcallback.ml
 	@$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo
 	@./program > bytecode.result
-	@diff -q reference bytecode.result || (echo " => failed" && exit 1) 
+	@$(DIFF) reference bytecode.result || (echo " => failed" && exit 1) 
 	@echo " => passed"
 
 run-opt: common
-	@printf " ... testing 'native':"
-	@$(OCAMLOPT) -c tcallback.ml
-	@$(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx
-	@./program > native.result
-	@diff -q reference native.result || (echo " => failed" && exit 1) 
-	@echo " => passed"
+	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	  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"; \
+	fi
+	
+promote: defaultpromote
 
 clean: defaultclean
 	@rm -f *.result ./program
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/embedded/.svnignore b/testsuite/tests/embedded/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/embedded/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < program.result
-	@diff -q program.reference program.result > /dev/null || (echo " => failed" && exit 1)
+	@$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1)
 	@echo " => passed"
+	
+promote: defaultpromote
 
 clean: defaultclean
 	@rm -f *.result ./program
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml
index 4ebed1e7..65c7a610 100644
--- a/testsuite/tests/embedded/cmcaml.ml
+++ b/testsuite/tests/embedded/cmcaml.ml
@@ -1,4 +1,4 @@
-(* Caml part of the code *)
+(* OCaml part of the code *)
 
 let rec fib n =
   if n < 2 then 1 else fib(n-1) + fib(n-2)
diff --git a/testsuite/tests/embedded/cmmain.c b/testsuite/tests/embedded/cmmain.c
index 87647ac5..6c27fe1e 100644
--- a/testsuite/tests/embedded/cmmain.c
+++ b/testsuite/tests/embedded/cmmain.c
@@ -9,7 +9,7 @@ extern char * format_result(int n);
 
 int main(int argc, char ** argv)
 {
-  printf("Initializing Caml code...\n");
+  printf("Initializing OCaml code...\n");
 #ifdef NO_BYTECODE_FILE
   caml_startup(argv);
 #else
diff --git a/testsuite/tests/embedded/program.reference b/testsuite/tests/embedded/program.reference
index e2752b72..4f27810c 100644
--- a/testsuite/tests/embedded/program.reference
+++ b/testsuite/tests/embedded/program.reference
@@ -1,4 +1,4 @@
-Initializing Caml code...
+Initializing OCaml code...
 Back in C code...
 Computing fib(20)...
 Result = 10946
diff --git a/testsuite/tests/gc-roots/.svnignore b/testsuite/tests/gc-roots/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/gc-roots/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <
+    List.iter (fun t -> assert (f t == t_ref)) [x; y; z]
+  )
+    [
+      (fun t -> t.x), x;
+      (fun t -> t.y), y;
+      (fun t -> t.z), z;
+    ]
diff --git a/testsuite/tests/letrec/backreferences.reference b/testsuite/tests/letrec/backreferences.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
new file mode 100644
index 00000000..a7d03388
--- /dev/null
+++ b/testsuite/tests/letrec/class_1.ml
@@ -0,0 +1,5 @@
+(* class expression are compiled to recursive bindings *)
+class test =
+object
+  method x = 1
+end
diff --git a/testsuite/tests/letrec/class_1.reference b/testsuite/tests/letrec/class_1.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
new file mode 100644
index 00000000..71c7880d
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.ml
@@ -0,0 +1,8 @@
+(* class expressions may also contain local recursive bindings *)
+class test =
+  let rec f = print_endline "f"; fun x -> g x
+      and g = print_endline "g"; fun x -> f x in
+object
+  method f : 'a 'b. 'a -> 'b = f
+  method g : 'a 'b. 'a -> 'b = g
+end
diff --git a/testsuite/tests/letrec/class_2.reference b/testsuite/tests/letrec/class_2.reference
new file mode 100644
index 00000000..ab713757
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.reference
@@ -0,0 +1,2 @@
+f
+g
diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
new file mode 100644
index 00000000..5b88844d
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -0,0 +1,20 @@
+(* test evaluation order
+
+   'y' is translated into a constant, and is therefore considered
+   non-recursive. With the current letrec compilation method,
+   it should be evaluated before x and z.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (print_endline "x"; Tree [y; z])
+  and y = (print_endline "y"; Tree [])
+  and z = (print_endline "z"; Tree [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false
diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference
new file mode 100644
index 00000000..f471662b
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.reference
@@ -0,0 +1,3 @@
+y
+x
+z
diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
new file mode 100644
index 00000000..736f82ad
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -0,0 +1,18 @@
+(* 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.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (Tree [(print_endline "x"; y); z])
+  and y = Tree (print_endline "y"; [])
+  and z = Tree (print_endline "z"; [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false
diff --git a/testsuite/tests/letrec/evaluation_order_2.reference b/testsuite/tests/letrec/evaluation_order_2.reference
new file mode 100644
index 00000000..04ec35a6
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.reference
@@ -0,0 +1,3 @@
+x
+y
+z
diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
new file mode 100644
index 00000000..8f76a8f8
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -0,0 +1,11 @@
+type t = { x : t; y : t }
+
+let p = print_endline
+
+let test =
+  let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) }
+      and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) }
+   in
+   assert (x.x == x); assert (x.y == y);
+   assert (y.x == x); assert (y.y == y);
+   ()
diff --git a/testsuite/tests/letrec/evaluation_order_3.reference b/testsuite/tests/letrec/evaluation_order_3.reference
new file mode 100644
index 00000000..5b8c549e
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.reference
@@ -0,0 +1,6 @@
+x
+x_y
+x_x
+y
+y_y
+y_x
diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
new file mode 100644
index 00000000..cdfa9d2f
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -0,0 +1,10 @@
+(* a bug in cmmgen.ml provokes a change in compilation order between
+   ocamlc and ocamlopt in certain letrec-bindings involving float
+   arrays *)
+let test =
+  let rec x = print_endline "x"; [| 1; 2; 3 |]
+      and y = print_endline "y"; [| 1.; 2.; 3. |]
+  in
+  assert (x = [| 1; 2; 3 |]);
+  assert (y = [| 1.; 2.; 3. |]);
+  ()
diff --git a/testsuite/tests/letrec/float_block_1.reference b/testsuite/tests/letrec/float_block_1.reference
new file mode 100644
index 00000000..b77b4eb1
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.reference
@@ -0,0 +1,2 @@
+x
+y
diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
new file mode 100644
index 00000000..968cba4e
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -0,0 +1,7 @@
+(* a bug in cmmgen.ml provokes a segfault in certain natively compiled
+   letrec-bindings involving float arrays *)
+let test =
+  let rec x = [| y; y |] and y = 1. in
+  assert (x = [| 1.; 1. |]);
+  assert (y = 1.);
+  ()
diff --git a/testsuite/tests/letrec/float_block_2.reference b/testsuite/tests/letrec/float_block_2.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
new file mode 100644
index 00000000..5686e493
--- /dev/null
+++ b/testsuite/tests/letrec/lists.ml
@@ -0,0 +1,8 @@
+(* 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
+  match li with
+    | 0::1::2::3::4::5::6::7::8::9::
+        0::1::2::3::4::5::6::7::8::9::li' ->
+      assert (li == li')
+    | _ -> assert false
diff --git a/testsuite/tests/letrec/lists.reference b/testsuite/tests/letrec/lists.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
new file mode 100644
index 00000000..e79f79ec
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -0,0 +1,8 @@
+(* mixing values and closures may exercise interesting code paths *)
+type t = A of (int -> int)
+let test =
+  let rec x = A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with A g -> g 0
+  in assert (f 1 = 2)
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.reference b/testsuite/tests/letrec/mixing_value_closures_1.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
new file mode 100644
index 00000000..eb5fcb74
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -0,0 +1,8 @@
+(* a polymorphic variant of test3.ml; found a real bug once *)
+let test =
+  let rec x = `A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with `A g -> g 0
+  in
+  assert (f 1 = 2)
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.reference b/testsuite/tests/letrec/mixing_value_closures_2.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
new file mode 100644
index 00000000..a5b6c51f
--- /dev/null
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -0,0 +1,11 @@
+(* a simple test with mutually recursive functions *)
+let test =
+  let rec even = function
+    | 0 -> true
+    | n -> odd (n - 1)
+  and odd = function
+    | 0 -> false
+    | n -> even (n - 1)
+  in
+  List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0)))
+    [0;1;2;3;4;5;6]
diff --git a/testsuite/tests/letrec/mutual_functions.reference b/testsuite/tests/letrec/mutual_functions.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-bigarray-2/Makefile b/testsuite/tests/lib-bigarray-2/Makefile
index 74b02913..678c8c88 100644
--- a/testsuite/tests/lib-bigarray-2/Makefile
+++ b/testsuite/tests/lib-bigarray-2/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 LIBRARIES=unix bigarray
 C_FILES=bigarrfstub
 F_FILES=bigarrf
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-bigarray/Makefile b/testsuite/tests/lib-bigarray/Makefile
index bb5076e7..5bfaa030 100644
--- a/testsuite/tests/lib-bigarray/Makefile
+++ b/testsuite/tests/lib-bigarray/Makefile
@@ -1,4 +1,5 @@
+BASEDIR=../..
 LIBRARIES=unix bigarray
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+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 85901400..28ed9af6 100644
--- a/testsuite/tests/lib-bigarray/bigarrays.ml
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -384,6 +384,12 @@ let _ =
   test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i]
                              Complex.i 1 1);
 
+  testing_function "release";
+  let a = from_list int [1;2;3;4;5] in
+  test 1 (Array1.dim a) 5;
+  Array1.release a;
+  test 2 (Array1.dim a) 0;
+  
 (* Bi-dimensional arrays *)
 
   print_newline();
@@ -533,6 +539,14 @@ let _ =
   test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]);
   test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]);
 
+  testing_function "release";
+  let a = (make_array2 int c_layout 0 4 6 id) in
+  test 1 (Array2.dim1 a) 4;
+  test 2 (Array2.dim2 a) 6;
+  Array2.release a;
+  test 3 (Array2.dim1 a) 0;
+  test 4 (Array2.dim2 a) 0;
+
 (* Tri-dimensional arrays *)
 
   print_newline();
@@ -654,6 +668,16 @@ let _ =
   test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]);
   test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]);
 
+  testing_function "release";
+  let a = (make_array3 int c_layout 0 4 5 6 id) in
+  test 1 (Array3.dim1 a) 4;
+  test 2 (Array3.dim2 a) 5;
+  test 3 (Array3.dim3 a) 6;
+  Array3.release a;
+  test 4 (Array3.dim1 a) 0;
+  test 5 (Array3.dim2 a) 0;
+  test 6 (Array3.dim3 a) 0;
+
 (* Reshaping *)
   print_newline();
   testing_function "------ Reshaping --------";
@@ -717,6 +741,7 @@ let _ =
     let a = Array1.map_file fd float64 c_layout true 10000 in
     Unix.close fd;
     for i = 0 to 9999 do a.{i} <- float i done;
+    Array1.release a;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in
     Unix.close fd;
@@ -727,7 +752,8 @@ let _ =
       done
     done;
     test 1 !ok true;
-    b.{50,50} <- (-1.0);
+    b.{50,50} <- (-1.0);         (* private mapping -> no effect on file *)
+    Array2.release b;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd float64 c_layout false (-1) 100 in
     Unix.close fd;
@@ -738,6 +764,7 @@ let _ =
       done
     done;
     test 2 !ok true;
+    Array2.release c;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd ~pos:800L float64 c_layout false (-1) 100 in
     Unix.close fd;
@@ -748,6 +775,7 @@ let _ =
       done
     done;
     test 3 !ok true;
+    Array2.release c;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd ~pos:79200L float64 c_layout false (-1) 100 in
     Unix.close fd;
@@ -755,12 +783,13 @@ let _ =
     for j = 0 to 99 do
       if c.{0,j} <> float (100 * 99 + j) then ok := false
     done;
-    test 4 !ok true
+    test 4 !ok true;
+    Array2.release c;
+    test 5 (Array2.dim1 c) 0;        
+    test 5 (Array2.dim2 c) 0
   end;
-  (* Force garbage collection of the mapped bigarrays above, otherwise
-     Win32 doesn't let us erase the file.  Notice the begin...end above
-     so that the VM doesn't keep stack references to the mapped bigarrays. *)
-  Gc.full_major();
+  (* Win32 doesn't let us erase the file if any mapping on the file is
+     still active.  Normally, they have all been released explicitly. *)
   Sys.remove mapped_file;
 
   ()
diff --git a/testsuite/tests/lib-bigarray/bigarrays.reference b/testsuite/tests/lib-bigarray/bigarrays.reference
index bdc7beae..def96fe4 100644
--- a/testsuite/tests/lib-bigarray/bigarrays.reference
+++ b/testsuite/tests/lib-bigarray/bigarrays.reference
@@ -17,6 +17,8 @@ sub
  1... 2... 3... 4... 5... 6... 7... 8... 9...
 blit, fill
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+release
+ 1... 2...
 
 ------ Array2 --------
 
@@ -32,6 +34,8 @@ sub
  1... 2...
 slice
  1... 2... 3... 4... 5... 6... 7... 8...
+release
+ 1... 2... 3... 4...
 
 ------ Array3 --------
 
@@ -45,6 +49,8 @@ dim
  1... 2... 3... 4... 5... 6...
 slice1
  1... 2... 3... 4... 5... 6... 7...
+release
+ 1... 2... 3... 4... 5... 6...
 
 ------ Reshaping --------
 
@@ -58,4 +64,4 @@ reshape_2
 output_value/input_value
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
 map_file
- 1... 2... 3... 4...
+ 1... 2... 3... 4... 5... 5...
diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml
index 17465df5..10c22f1d 100644
--- a/testsuite/tests/lib-bigarray/fftba.ml
+++ b/testsuite/tests/lib-bigarray/fftba.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/lib-digest/.svnignore b/testsuite/tests/lib-digest/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/lib-digest/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < 1 && (Sys.argv.(1) = "-benchmark") then begin
     let s = String.make 50000 'a' in
     let num_iter = 1000 in
-    time "Caml implementation" num_iter
+    time "OCaml implementation" num_iter
       (fun () ->
         let ctx = init() in
         update ctx s 0 (String.length s);
diff --git a/testsuite/tests/lib-dynlink-bytecode/.ignore b/testsuite/tests/lib-dynlink-bytecode/.ignore
new file mode 100644
index 00000000..098ab51e
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/.ignore
@@ -0,0 +1,4 @@
+main
+static
+custom
+marshal.data
diff --git a/testsuite/tests/lib-dynlink-bytecode/.svnignore b/testsuite/tests/lib-dynlink-bytecode/.svnignore
deleted file mode 100644
index bb929434..00000000
--- a/testsuite/tests/lib-dynlink-bytecode/.svnignore
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < main.result
-	@diff -q main.reference main.result > /dev/null || (echo " => failed" && exit 1)
+	@$(DIFF) main.reference main.result > /dev/null || (echo " => failed" && exit 1)
 	@echo " => passed"
 
 	@printf " ... testing 'static'"
 	@export LD_LIBRARY_PATH=`pwd` && ./static > static.result
-	@diff -q static.reference static.result > /dev/null || (echo " => failed" && exit 1)
+	@$(DIFF) static.reference static.result > /dev/null || (echo " => failed" && exit 1)
 	@echo " => passed"
 
 	@printf " ... testing 'custom'"
 	@export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result
-	@diff -q custom.reference custom.result > /dev/null || (echo " => failed" && exit 1)
+	@$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1)
 	@echo " => passed"
+	
+promote: defaultpromote
 
 clean: defaultclean
-	@rm -f ./main ./static ./custom *.result
+	@rm -f ./main ./static ./custom *.result marshal.data
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-bytecode/custom.reference b/testsuite/tests/lib-dynlink-bytecode/custom.reference
index f7eeb3ae..c9d2b575 100644
--- a/testsuite/tests/lib-dynlink-bytecode/custom.reference
+++ b/testsuite/tests/lib-dynlink-bytecode/custom.reference
@@ -1,5 +1,5 @@
-ABCDEF
 This is stub2, calling stub1:
 This is stub1!
 Ok!
 This is stub1!
+ABCDEF
diff --git a/testsuite/tests/lib-dynlink-bytecode/main.ml b/testsuite/tests/lib-dynlink-bytecode/main.ml
index bd980f10..b7950428 100644
--- a/testsuite/tests/lib-dynlink-bytecode/main.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/main.ml
@@ -1,3 +1,8 @@
+let f x = print_string "This is Main.f\n"; x
+
+let () = Registry.register f
+
+let _ =
   Dynlink.init ();
   Dynlink.allow_unsafe_modules true;
   for i = 1 to Array.length Sys.argv - 1 do
@@ -14,4 +19,19 @@
 	    (Dynlink.error_message err)
       | exn ->
 	  Printf.printf "Error: %s\n" (Printexc.to_string exn)
-  done
+  done;
+  flush stdout;
+  try
+    let oc = open_out_bin "marshal.data" in
+    Marshal.to_channel oc (Registry.get_functions()) [Marshal.Closures];
+    close_out oc;
+    let ic = open_in_bin "marshal.data" in
+    let l = (Marshal.from_channel ic : (int -> int) list) in
+    close_in ic;
+    List.iter
+      (fun f ->
+        let res = f 0 in
+        Printf.printf "Result is: %d\n" res)
+      l
+  with Failure s ->
+    Printf.printf "Failure: %s\n" s
diff --git a/testsuite/tests/lib-dynlink-bytecode/main.reference b/testsuite/tests/lib-dynlink-bytecode/main.reference
index df46049b..577292f9 100644
--- a/testsuite/tests/lib-dynlink-bytecode/main.reference
+++ b/testsuite/tests/lib-dynlink-bytecode/main.reference
@@ -1,7 +1,13 @@
 Loading plug1.cma
+This is stub1!
 ABCDEF
 Loading plug2.cma
-This is stub1!
 This is stub2, calling stub1:
 This is stub1!
 Ok!
+This is Plug2.f
+Result is: 2
+This is Plug1.f
+Result is: 1
+This is Main.f
+Result is: 0
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug1.ml b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
index 32460451..d0490689 100644
--- a/testsuite/tests/lib-dynlink-bytecode/plug1.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
@@ -1,4 +1,7 @@
 external stub1: unit -> string = "stub1"
 
+let f x = print_string "This is Plug1.f\n"; x + 1
+
+let () = Registry.register f
 
 let () = print_endline (stub1 ())
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug2.ml b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
index 05f4fdae..350374e5 100644
--- a/testsuite/tests/lib-dynlink-bytecode/plug2.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
@@ -1,4 +1,7 @@
 external stub2: unit -> unit = "stub2"
 
+let f x = print_string "This is Plug2.f\n"; x + 2
+
+let () = Registry.register f
 
 let () = stub2 ()
diff --git a/testsuite/tests/lib-dynlink-bytecode/registry.ml b/testsuite/tests/lib-dynlink-bytecode/registry.ml
new file mode 100644
index 00000000..e0f76423
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/registry.ml
@@ -0,0 +1,7 @@
+let functions = ref ([]: (int -> int) list)
+
+let register f =
+  functions := f :: !functions
+
+let get_functions () =
+  !functions
diff --git a/testsuite/tests/lib-dynlink-bytecode/static.reference b/testsuite/tests/lib-dynlink-bytecode/static.reference
index 32281bcf..4faa129c 100644
--- a/testsuite/tests/lib-dynlink-bytecode/static.reference
+++ b/testsuite/tests/lib-dynlink-bytecode/static.reference
@@ -1,5 +1,5 @@
-ABCDEF
 This is stub1!
+ABCDEF
 This is stub2, calling stub1:
 This is stub1!
 Ok!
diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c
index 18ddf3f1..dcae562a 100644
--- a/testsuite/tests/lib-dynlink-bytecode/stub1.c
+++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c
@@ -5,7 +5,7 @@
 
 value stub1() {
   CAMLlocal1(x);
-  printf("This is stub1!\n");
+  printf("This is stub1!\n"); fflush(stdout);
   x = caml_copy_string("ABCDEF");
   return x;
 }
diff --git a/testsuite/tests/lib-dynlink-bytecode/stub2.c b/testsuite/tests/lib-dynlink-bytecode/stub2.c
index a1186735..4c6e6e3c 100644
--- a/testsuite/tests/lib-dynlink-bytecode/stub2.c
+++ b/testsuite/tests/lib-dynlink-bytecode/stub2.c
@@ -6,8 +6,8 @@
 extern value stub1();
 
 value stub2() {
-  printf("This is stub2, calling stub1:\n");
+  printf("This is stub2, calling stub1:\n"); fflush(stdout);
   stub1();
-  printf("Ok!\n");
+  printf("Ok!\n"); fflush(stdout);
   return Val_unit;
 }
diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
index 774eaaca..c65b044e 100644
--- a/testsuite/tests/lib-dynlink-csharp/Makefile
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -1,6 +1,12 @@
+BASEDIR=../..
 CSC=csc
 
-default: prepare bytecode bytecode-dll native native-dll
+default:
+	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	  $(MAKE) all; \
+	fi
+
+all: prepare bytecode bytecode-dll native native-dll
 
 prepare:
 	@$(OCAMLC) -c plugin.ml
@@ -14,7 +20,7 @@ bytecode:
 	  $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
 	  $(CSC) /out:main.exe main.cs; \
 	  ./main.exe > bytecode.result; \
-	  diff -q bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
 	fi
 
 bytecode-dll:
@@ -26,7 +32,7 @@ bytecode-dll:
 	  $(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 -q bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
 	fi
 
 native:
@@ -37,7 +43,7 @@ native:
 	  $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
 	  $(CSC) /out:main.exe main.cs; \
 	  ./main.exe > native.result; \
-	  diff -q native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
 	fi
 
 native-dll:
@@ -49,10 +55,12 @@ native-dll:
 	  $(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 -q native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
 	fi
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.result *.exe *.dll
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-csharp/bytecode.reference b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
index 65592193..a76daa23 100644
--- a/testsuite/tests/lib-dynlink-csharp/bytecode.reference
+++ b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
@@ -1,4 +1,4 @@
-Now starting the Caml engine.
+Now starting the OCaml engine.
 Main is running.
 Loading ../../../otherlibs/bigarray/bigarray.cma
 I'm the plugin.
diff --git a/testsuite/tests/lib-dynlink-csharp/main.cs b/testsuite/tests/lib-dynlink-csharp/main.cs
index a03bfd60..5cbb8e86 100755
--- a/testsuite/tests/lib-dynlink-csharp/main.cs
+++ b/testsuite/tests/lib-dynlink-csharp/main.cs
@@ -5,7 +5,7 @@ public class M {
   public static extern void start_caml_engine();
 
   public static void Main() {
-    System.Console.WriteLine("Now starting the Caml engine.");
+    System.Console.WriteLine("Now starting the OCaml engine.");
     start_caml_engine();
   }
 }
diff --git a/testsuite/tests/lib-dynlink-csharp/native.reference b/testsuite/tests/lib-dynlink-csharp/native.reference
index b6c9e5c4..684f979a 100644
--- a/testsuite/tests/lib-dynlink-csharp/native.reference
+++ b/testsuite/tests/lib-dynlink-csharp/native.reference
@@ -1,4 +1,4 @@
-Now starting the Caml engine.
+Now starting the OCaml engine.
 Main is running.
 Loading ../../../otherlibs/bigarray/bigarray.cmxs
 I'm the plugin.
diff --git a/testsuite/tests/lib-dynlink-native/.ignore b/testsuite/tests/lib-dynlink-native/.ignore
new file mode 100644
index 00000000..601ed1ff
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/.ignore
@@ -0,0 +1,4 @@
+mypack.pack.s
+result
+main
+marshal.data
diff --git a/testsuite/tests/lib-dynlink-native/.svnignore b/testsuite/tests/lib-dynlink-native/.svnignore
deleted file mode 100644
index 44c6a068..00000000
--- a/testsuite/tests/lib-dynlink-native/.svnignore
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < result
-	@diff -q reference result > /dev/null || (echo " => failed" && exit 1)
+	@./main plugin.so plugin2.so plugin_thread.so > result
+	@$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1)
 	@echo " => passed"
 
 main: api.cmx main.cmx
@@ -62,9 +70,12 @@ mylib.cmxa: plugin.cmx plugin2.cmx
 factorial.$(O): factorial.c
 	@$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" factorial.c
 
+promote:
+	@cp result reference
+
 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
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml
index 843a1c78..304ee1f1 100644
--- a/testsuite/tests/lib-dynlink-native/api.ml
+++ b/testsuite/tests/lib-dynlink-native/api.ml
@@ -14,5 +14,7 @@ let cbs = ref []
 let add_cb f = cbs := f :: !cbs
 let runall () = List.iter (fun f -> f ()) !cbs
 
+(*
 let () =
   at_exit runall
+*)
diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml
index b21253fb..04b3aef7 100644
--- a/testsuite/tests/lib-dynlink-native/main.ml
+++ b/testsuite/tests/lib-dynlink-native/main.ml
@@ -1,3 +1,6 @@
+let () =
+  Api.add_cb (fun () -> print_endline "Callback from main")
+
 let ()  =
   Dynlink.init ();
   Dynlink.allow_unsafe_modules true;
@@ -15,6 +18,18 @@ let ()  =
 	    (Dynlink.error_message err)
       | exn ->
 	  Printf.printf "Error: %s\n" (Printexc.to_string exn)
-  done
+  done;
+  flush stdout;
+  try
+    let oc = open_out_bin "marshal.data" in
+    Marshal.to_channel oc !Api.cbs [Marshal.Closures];
+    close_out oc;
+    let ic = open_in_bin "marshal.data" in
+    let l = (Marshal.from_channel ic : (unit -> unit) list) in
+    close_in ic;
+    List.iter (fun f -> f()) l
+  with Failure s ->
+    Printf.printf "Failure: %s\n" s
+
 
 
diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml
index 501f1bfd..f307b4f1 100644
--- a/testsuite/tests/lib-dynlink-native/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin.ml
@@ -6,5 +6,6 @@ let facts = [ fact 1; fact 2; fact 3; fact (Random.int 4) ]
 
 let () =
   Api.reg_mod "Plugin";
+  Api.add_cb (fun () -> print_endline "Callback from plugin");
   print_endline "COUCOU"; 
   ()
diff --git a/testsuite/tests/lib-dynlink-native/plugin2.ml b/testsuite/tests/lib-dynlink-native/plugin2.ml
index daecace8..109c129d 100644
--- a/testsuite/tests/lib-dynlink-native/plugin2.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin2.ml
@@ -2,7 +2,7 @@
 
 let () =
   Api.reg_mod "Plugin2";
+  Api.add_cb (fun () -> print_endline "Callback from plugin2");
 (*  let i = ex 3 in*)
   List.iter (fun i -> Printf.printf "%i\n" i) Plugin.facts;
-  Printf.printf "XXX\n";
-  raise Exit
+  Printf.printf "XXX\n"
diff --git a/testsuite/tests/lib-dynlink-native/reference b/testsuite/tests/lib-dynlink-native/reference
index c6adb139..e9e4ee45 100644
--- a/testsuite/tests/lib-dynlink-native/reference
+++ b/testsuite/tests/lib-dynlink-native/reference
@@ -1,3 +1,13 @@
+Loading plugin.so
+Registering module Plugin
+COUCOU
+Loading plugin2.so
+Registering module Plugin2
+1
+2
+6
+1
+XXX
 Loading plugin_thread.so
 Registering module Plugin_thread
 Thread
@@ -15,3 +25,6 @@ Thread
 Thread
 Thread
 Thread
+Callback from plugin2
+Callback from plugin
+Callback from main
diff --git a/testsuite/tests/lib-hashtbl/Makefile b/testsuite/tests/lib-hashtbl/Makefile
new file mode 100644
index 00000000..4ba0bffc
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/Makefile
@@ -0,0 +1,3 @@
+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
new file mode 100644
index 00000000..5699587c
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/hfun.ml
@@ -0,0 +1,50 @@
+(* Testing the hash function Hashtbl.hash *)
+(* What is tested:
+     - reproducibility on various platforms, esp. 32/64 bit issues
+     - equal values hash equally, esp NaNs. *)
+
+open Printf
+
+let _ =
+  printf "-- Strings:\n";
+  printf "\"\"\t\t%08x\n" (Hashtbl.hash "");
+  printf "\"Hello world\"\t%08x\n" (Hashtbl.hash "Hello world");
+
+  printf "-- Integers:\n";
+  printf "0\t\t%08x\n" (Hashtbl.hash 0);
+  printf "-1\t\t%08x\n" (Hashtbl.hash (-1));
+  printf "42\t\t%08x\n" (Hashtbl.hash 42);
+  printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFF);
+  printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000));
+
+  printf "-- Floats:\n";
+  printf "+0.0\t\t%08x\n" (Hashtbl.hash 0.0);
+  printf "-0.0\t\t%08x\n" (Hashtbl.hash (-. 0.0));
+  printf "+infty\t\t%08x\n" (Hashtbl.hash infinity);
+  printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity);
+  printf "NaN\t\t%08x\n" (Hashtbl.hash nan);
+  printf "NaN#2\t\t%08x\n" (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL));
+  printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0));
+
+  printf "-- Native integers:\n";
+  printf "0\t\t%08x\n" (Hashtbl.hash 0n);
+  printf "-1\t\t%08x\n" (Hashtbl.hash (-1n));
+  printf "42\t\t%08x\n" (Hashtbl.hash 42n);
+  printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFFn);
+  printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000n));
+
+  printf "-- Lists:\n";
+  printf "[0..10]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10]);
+  printf "[0..12]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10;11;12]);
+  printf "[10..0]\t\t%08x\n" (Hashtbl.hash [10;9;8;7;6;5;4;3;2;1;0]);
+
+  ()
+
+
+
+
+
+
+
+
+  
diff --git a/testsuite/tests/lib-hashtbl/hfun.reference b/testsuite/tests/lib-hashtbl/hfun.reference
new file mode 100644
index 00000000..2e92cf43
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/hfun.reference
@@ -0,0 +1,27 @@
+-- Strings:
+""		00000000
+"Hello world"	364b8272
+-- Integers:
+0		07be548a
+-1		3653e015
+42		1792870b
+2^30-1		23c392d0
+-2^30		0c66fde3
+-- Floats:
++0.0		0f478b8c
+-0.0		0f478b8c
++infty		23ea56fb
+-infty		059f7872
+NaN		3228858d
+NaN#2		3228858d
+NaN#3		3228858d
+-- Native integers:
+0		3f19274a
+-1		3653e015
+42		3e33aef8
+2^30-1		3711bf46
+-2^30		2e71f39c
+-- Lists:
+[0..10]		0ade0fc9
+[0..12]		0ade0fc9
+[10..0]		0cd6259d
diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml
new file mode 100644
index 00000000..84a71beb
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/htbl.ml
@@ -0,0 +1,192 @@
+(* Hashtable operations, using maps as a reference *)
+
+open Printf
+
+module Test(H: Hashtbl.S) (M: Map.S with type key = H.key) = struct
+
+  let incl_mh m h =
+    try
+      M.iter
+        (fun k d ->
+          let d' = H.find h k in if d <> d' then raise Exit)
+        m;
+      true
+    with Exit | Not_found -> false
+
+  let domain_hm h m =
+    try
+      H.iter
+        (fun k d -> if not (M.mem k m) then raise Exit)
+        h;
+      true
+    with Exit -> false
+
+  let incl_hm h m =
+    try
+      H.iter
+        (fun k d ->
+           let d' = M.find k m in if d <> d' then raise Exit)
+        h;
+      true
+    with Exit | Not_found -> false
+
+  let test data =
+    let n = Array.length data in
+    let h = H.create 51 and m = ref M.empty in
+    (* Insert all data with H.add *)
+    Array.iter
+      (fun (k, d) -> H.add h k d; m := M.add k d !m)
+      data;
+    printf "Insertion: %s\n"
+           (if incl_mh !m h && domain_hm h !m then "passed" else "FAILED");
+    (* Insert all data with H.replace *)
+    H.clear h; m := M.empty;
+    Array.iter
+      (fun (k, d) -> H.replace h k d; m := M.add k d !m)
+      data;
+    printf "Insertion: %s\n"
+           (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED");
+    (* Remove some of the data *)
+    for i = 0 to n/3 - 1 do
+      let (k, _) = data.(i) in H.remove h k; m := M.remove k !m
+    done;
+    printf "Removal: %s\n"
+           (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED")
+
+end
+
+module MS = Map.Make(struct type t = string
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+module MI = Map.Make(struct type t = int
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+
+module MSP = Map.Make(struct type t = string*string
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+
+module MSL = Map.Make(struct type t = string list
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+
+(* Generic hash wrapped as a functorial hash *)
+
+module HofM (M: Map.S) : Hashtbl.S with type key = M.key =
+  struct
+    type key = M.key
+    type 'a t = (key, 'a) Hashtbl.t
+    let create s = Hashtbl.create s
+    let clear = Hashtbl.clear
+    let copy = Hashtbl.copy
+    let add = Hashtbl.add
+    let remove = Hashtbl.remove
+    let find = Hashtbl.find
+    let find_all = Hashtbl.find_all
+    let replace = Hashtbl.replace
+    let mem = Hashtbl.mem
+    let iter = Hashtbl.iter
+    let fold = Hashtbl.fold
+    let length = Hashtbl.length
+    let stats = Hashtbl.stats
+  end
+
+module HS1 = HofM(MS)
+module HI1 = HofM(MI)
+module HSP = HofM(MSP)
+module HSL = HofM(MSL)
+
+(* Specific functorial hashes *)
+
+module HS2 = Hashtbl.Make(struct type t = string
+                                 let equal (x:t) (y:t) = x=y
+                                 let hash = Hashtbl.hash end)
+
+module HI2 = Hashtbl.Make(struct type t = int
+                                 let equal (x:t) (y:t) = x=y
+                                 let hash = Hashtbl.hash end)
+(* Instantiating the test *)
+
+module TS1 = Test(HS1)(MS)
+module TS2 = Test(HS2)(MS)
+module TI1 = Test(HI1)(MI)
+module TI2 = Test(HI2)(MI)
+module TSP = Test(HSP)(MSP)
+module TSL = Test(HSL)(MSL)
+
+(* Data set: strings from a file, associated with their line number *)
+
+let file_data filename =
+  let ic = open_in filename in
+  let lineno = ref 0 in
+  let data = ref [] in
+  begin try
+    while true do
+      let l = input_line ic in
+      incr lineno;
+      data := (l, !lineno) :: !data
+    done
+  with End_of_file -> ()
+  end;
+  close_in ic;
+  Array.of_list !data
+
+(* Data set: fixed strings *)
+
+let string_data = [|
+  "Si", 0; "non", 1; "e", 2; "vero", 3; "e", 4; "ben", 5; "trovato", 6;
+  "An", 10; "apple", 11; "a", 12; "day", 13; "keeps", 14; "the", 15;
+  "doctor", 16; "away", 17;
+  "Pierre", 20; "qui", 21; "roule", 22; "n'amasse", 23; "pas", 24; "mousse", 25;
+  "Asinus", 30; "asinum", 31; "fricat", 32
+|]
+
+(* Data set: random integers *)
+
+let random_integers num range =
+  let data = Array.make num (0,0) in
+  for i = 0 to num - 1 do
+    data.(i) <- (Random.int range, i)
+  done;
+  data
+
+(* Data set: pairs *)
+
+let pair_data data =
+  Array.map (fun (k, d) -> ((k, k), d)) data
+
+(* Data set: lists *)
+
+let list_data data =
+  let d = Array.make (Array.length data / 10) ([], 0) in
+  let j = ref 0 in
+  let rec mklist n =
+    if n <= 0 || !j >= Array.length data then [] else begin
+      let hd = fst data.(!j) in
+      incr j;
+      let tl = mklist (n-1) in
+      hd :: tl
+    end in
+  for i = 0 to Array.length d - 1 do
+    d.(i) <- (mklist (Random.int 16), i)
+  done;
+  d
+
+(* The test *)
+
+let _ =
+  printf "-- Random integers, large range\n%!";
+  TI1.test (random_integers 100_000 1_000_000);
+  printf "-- Random integers, narrow range\n%!";
+  TI2.test (random_integers 100_000 1_000);
+  let d =
+    try file_data "/usr/share/dict/words" with Sys_error _ -> string_data in
+  printf "-- Strings, generic interface\n%!";
+  TS1.test d;
+  printf "-- Strings, functorial interface\n%!";
+  TS2.test d;
+  printf "-- Pairs of strings\n%!";
+  TSP.test (pair_data d);
+  printf "-- Lists of strings\n%!";
+  TSL.test (list_data d)
+ 
diff --git a/testsuite/tests/lib-hashtbl/htbl.reference b/testsuite/tests/lib-hashtbl/htbl.reference
new file mode 100644
index 00000000..08ca22f0
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/htbl.reference
@@ -0,0 +1,24 @@
+-- Random integers, large range
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Random integers, narrow range
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Strings, generic interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Strings, functorial interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Lists of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
diff --git a/testsuite/tests/lib-marshal/Makefile b/testsuite/tests/lib-marshal/Makefile
index df63a1fd..1f78273d 100644
--- a/testsuite/tests/lib-marshal/Makefile
+++ b/testsuite/tests/lib-marshal/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=intext
 C_FILES=intextaux
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-num-2/Makefile b/testsuite/tests/lib-num-2/Makefile
index 7b7ffec4..7a307e41 100644
--- a/testsuite/tests/lib-num-2/Makefile
+++ b/testsuite/tests/lib-num-2/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 LIBRARIES=nums
 PROGRAM_ARGS=1000
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-num/Makefile b/testsuite/tests/lib-num/Makefile
index 8b7b327a..08ebbd97 100644
--- a/testsuite/tests/lib-num/Makefile
+++ b/testsuite/tests/lib-num/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 MODULES=test test_nats test_big_ints test_ratios test_nums test_io
 MAIN_MODULE=end_test
 ADD_COMPFLAGS=-w a
 LIBRARIES=nums
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-num/end_test.reference b/testsuite/tests/lib-num/end_test.reference
index 8a78296e..8e7ac4b6 100644
--- a/testsuite/tests/lib-num/end_test.reference
+++ b/testsuite/tests/lib-num/end_test.reference
@@ -83,6 +83,8 @@ shift_right_towards_zero_big_int
  1... 2...
 extract_big_int
  1... 2... 3... 4... 5... 6...
+hashing of big integers
+ 1... 2... 3... 4... 5... 6...
 create_ratio
  1... 2... 3... 4... 5... 6... 7... 8...
 create_normalized_ratio
diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
index 46ffc597..badc5216 100644
--- a/testsuite/tests/lib-num/test_big_ints.ml
+++ b/testsuite/tests/lib-num/test_big_ints.ml
@@ -922,3 +922,23 @@ test 5 eq_big_int
 test 6 eq_big_int
   (extract_big_int (big_int_of_int (-1)) 2048 254,
    zero_big_int);;
+
+testing_function "hashing of big integers";;
+
+test 1 eq_int (Hashtbl.hash zero_big_int,
+               955772237);;
+test 2 eq_int (Hashtbl.hash unit_big_int,
+               992063522);;
+test 3 eq_int (Hashtbl.hash (minus_big_int unit_big_int),
+               161678167);;
+test 4 eq_int (Hashtbl.hash (big_int_of_string "123456789123456789"),
+               755417385);;
+test 5 eq_int (Hashtbl.hash (sub_big_int 
+                               (big_int_of_string "123456789123456789")
+                               (big_int_of_string "123456789123456789")),
+               955772237);;
+test 6 eq_int (Hashtbl.hash (sub_big_int 
+                               (big_int_of_string "123456789123456789")
+                               (big_int_of_string "123456789123456788")),
+              992063522);;
+
diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile
new file mode 100644
index 00000000..94c40472
--- /dev/null
+++ b/testsuite/tests/lib-printf/Makefile
@@ -0,0 +1,7 @@
+#MODULES=
+MAIN_MODULE=tprintf
+ADD_COMPFLAGS=-I $(BASEDIR)/lib
+ADD_MODULES=testing
+
+include ../../makefiles/Makefile.one
+include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
new file mode 100644
index 00000000..16046a7c
--- /dev/null
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -0,0 +1,468 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                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.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *)
+
+(*
+
+A test file for the Printf module.
+
+*)
+
+open Testing;;
+open Printf;;
+
+try
+
+  printf "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  ");
+
+  printf "\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  ");
+
+  printf "\nu positive\n%!";
+  test (sprintf "%u" 42 = "42");
+  test (sprintf "%-4u" 42 = "42  ");
+  test (sprintf "%04u" 42 = "0042");
+  test (sprintf "%+u" 42 = "42");
+  test (sprintf "% u" 42 = "42");
+  test (sprintf "%#u" 42 = "42");
+  test (sprintf "%4u" 42 = "  42");
+  test (sprintf "%*u" 4 42 = "  42");
+  test (sprintf "%-0+ #6d" 42 = "+42   ");
+
+  printf "\nu negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%u" (-1) = "2147483647");
+  | 64 ->
+     test (sprintf "%u" (-1) = "9223372036854775807");
+  | _ -> test false
+  end;
+
+  printf "\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 ");
+
+  printf "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%x" (-42) = "7fffffd6");
+  | 64 ->
+     test (sprintf "%x" (-42) = "7fffffffffffffd6");
+  | _ -> test false
+  end;
+
+  printf "\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 ");
+
+  printf "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%X" (-42) = "7FFFFFD6");
+  | 64 ->
+     test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6");
+  | _ -> test false
+  end;
+
+  printf "\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  ");
+
+  printf "\no negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%o" (-42) = "17777777726");
+  | 64 ->
+     test (sprintf "%o" (-42) = "777777777777777777726");
+  | _ -> test false
+  end;
+
+  printf "\ns\n%!";
+  test (sprintf "%s" "foo" = "foo");
+  test (sprintf "%-5s" "foo" = "foo  ");
+  test (sprintf "%05s" "foo" = "  foo");
+  test (sprintf "%+s" "foo" = "foo");
+  test (sprintf "% s" "foo" = "foo");
+  test (sprintf "%#s" "foo" = "foo");
+  test (sprintf "%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");
+
+  printf "\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\"");
+
+  printf "\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 *)
+
+  printf "\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 *)
+
+  printf "\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     ");
+
+  printf "\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");
+*)
+
+  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    ");
+
+  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    ");
+
+(* %g gives strange results that correspond to neither %f nor %e
+  printf "\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
+  printf "\nG\n%!";
+*)
+
+  printf "\nB\n%!";
+  test (sprintf "%B" true = "true");
+  test (sprintf "%B" false = "false");
+
+  printf "ld/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  ");
+
+  printf "\nld/li negative\n%!";
+  test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43  ");
+  test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043");
+  test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%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  ");
+
+  printf "\nlu positive\n%!";
+  test (sprintf "%lu" 42l = "42");
+  test (sprintf "%-4lu" 42l = "42  ");
+  test (sprintf "%04lu" 42l = "0042");
+  test (sprintf "%+lu" 42l = "42");
+  test (sprintf "% lu" 42l = "42");
+  test (sprintf "%#lu" 42l = "42");
+  test (sprintf "%4lu" 42l = "  42");
+  test (sprintf "%*lu" 4 42l = "  42");
+  test (sprintf "%-0+ #6ld" 42l = "+42   ");
+
+  printf "\nlu negative\n%!";
+  test (sprintf "%lu" (-1l) = "4294967295");
+
+  printf "\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 ");
+
+  printf "\nlx negative\n%!";
+  test (sprintf "%lx" (-42l) = "ffffffd6");
+
+  printf "\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 ");
+
+  printf "\nlx negative\n%!";
+  test (sprintf "%lX" (-42l) = "FFFFFFD6");
+
+  printf "\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  ");
+
+  printf "\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. *)
+
+  printf "Ld/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  ");
+
+  printf "\nLd/Li negative\n%!";
+  test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43  ");
+  test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043");
+  test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%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  ");
+
+  printf "\nLu positive\n%!";
+  test (sprintf "%Lu" 42L = "42");
+  test (sprintf "%-4Lu" 42L = "42  ");
+  test (sprintf "%04Lu" 42L = "0042");
+  test (sprintf "%+Lu" 42L = "42");
+  test (sprintf "% Lu" 42L = "42");
+  test (sprintf "%#Lu" 42L = "42");
+  test (sprintf "%4Lu" 42L = "  42");
+  test (sprintf "%*Lu" 4 42L = "  42");
+  test (sprintf "%-0+ #6Ld" 42L = "+42   ");
+
+  printf "\nLu negative\n%!";
+  test (sprintf "%Lu" (-1L) = "18446744073709551615");
+
+  printf "\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 ");
+
+  printf "\nLx negative\n%!";
+  test (sprintf "%Lx" (-42L) = "ffffffffffffffd6");
+
+  printf "\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 ");
+
+  printf "\nLx negative\n%!";
+  test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6");
+
+  printf "\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  ");
+
+  printf "\nLo negative\n%!";
+  test (sprintf "%Lo" (-42L) = "1777777777777777777726");
+
+  printf "\na\n%!";
+  let x = ref () in
+  let f () y = if y == x then "ok" else "wrong" in
+  test (sprintf "%a" f x = "ok");
+
+  printf "\nt\n%!";
+  let f () = "ok" in
+  test (sprintf "%t" f = "ok");
+
+(* Does not work as expected.  Should be fixed to work like %s.
+  printf "\n{...%%}\n%!";
+  let f = format_of_string "%f/%s" in
+  test (sprintf "%{%f%s%}" f = "%f/%s");
+*)
+
+  printf "\n(...%%)\n%!";
+  let f = format_of_string "%d/foo/%s" in
+  test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar");
+
+  printf "\n! %% @ , and constants\n%!";
+  test (sprintf "%!" = "");
+  test (sprintf "%%" = "%");
+  test (sprintf "%@" = "@");
+  test (sprintf "%," = "");
+  test (sprintf "@" = "@");
+  test (sprintf "@@" = "@@");
+  test (sprintf "@%%" = "@%");
+
+  printf "\nend of tests\n%!";
+with e ->
+  printf "unexpected exception: %s\n%!" (Printexc.to_string e);
+  test false;
+;;
diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference
new file mode 100644
index 00000000..693db249
--- /dev/null
+++ b/testsuite/tests/lib-printf/tprintf.reference
@@ -0,0 +1,87 @@
+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 
+! % @ , and constants
+269 270 271 272 273 274 275 
+end of tests
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile
index 90a0ea6d..216b3963 100644
--- a/testsuite/tests/lib-scanf-2/Makefile
+++ b/testsuite/tests/lib-scanf-2/Makefile
@@ -1,21 +1,30 @@
+BASEDIR=../..
+
 default: compile run
 
 compile: tscanf2_io.cmo tscanf2_io.cmx
 	@$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml
 	@$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml
-	@$(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml
-	@$(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml
+	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	  $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \
+	  $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \
+	fi
 
 run:
 	@printf " ... testing with ocamlc"
 	@./master.byte ./slave.byte > result.byte 2>&1
-	@diff -q reference result.byte > /dev/null || (echo " => failed" && exit 1)
-	@printf " ocamlopt"
-	@./master.native ./slave.native > result.native 2>&1
-	@diff -q reference result.native > /dev/null || (echo " => failed" && exit 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"
 
+promote:
+	@cp result.byte reference
+
 clean: defaultclean
 	@rm -f master.* slave.* result.*
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-scanf/Makefile b/testsuite/tests/lib-scanf/Makefile
index 8f8b3c5b..eba47014 100644
--- a/testsuite/tests/lib-scanf/Makefile
+++ b/testsuite/tests/lib-scanf/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=tscanf
 ADD_COMPFLAGS=-I $(BASEDIR)/lib
 ADD_MODULES=testing
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+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 89b188b4..64e14426 100644
--- a/testsuite/tests/lib-scanf/tscanf.ml
+++ b/testsuite/tests/lib-scanf/tscanf.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                            Objective Caml                             *)
+(*                                 OCaml                                 *)
 (*                                                                       *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt            *)
 (*                                                                       *)
@@ -585,7 +585,7 @@ and test27 () =
  (test27 ())
 ;;
 
-(* To scan a Caml string:
+(* To scan an OCaml string:
    the format is "\"%s@\"".
    A better way would be to add a %S (String.escaped), a %C (Char.escaped).
    This is now available. *)
@@ -950,7 +950,7 @@ test (test340 () && test35 ())
 
 (* The prefered reader functionnals. *)
 
-(* To read a list as in Caml (elements are ``blank + semicolon + blank''
+(* To read a list as in OCaml (elements are ``blank + semicolon + blank''
    separated, and the list is enclosed in brackets). *)
 let rec read_elems read_elem accu ib =
   kscanf ib (fun ib exc -> accu)
@@ -1444,12 +1444,22 @@ let test57 () =
 test (test57 ())
 ;;
 
-(*
 let test58 () =
+     sscanf "string1%string2" "%s@%%s" id = "string1"
+  && sscanf "string1%string2" "%s@%%%s" (^) = "string1string2"
+  && sscanf "string1@string2" "%[a-z0-9]@%s" (^) = "string1string2"
+  && sscanf "string1@%string2" "%[a-z0-9]%@%%%s" (^) = "string1string2"
 ;;
 
 test (test58 ())
 ;;
+
+(*
+let test59 () =
+;;
+
+test (test59 ())
+;;
 *)
 
 (* To be continued ...
diff --git a/testsuite/tests/lib-scanf/tscanf.reference b/testsuite/tests/lib-scanf/tscanf.reference
index edeff672..3c9fa442 100644
--- a/testsuite/tests/lib-scanf/tscanf.reference
+++ b/testsuite/tests/lib-scanf/tscanf.reference
@@ -1,2 +1,2 @@
-0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 
+0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 
 All tests succeeded.
diff --git a/testsuite/tests/lib-set/Makefile b/testsuite/tests/lib-set/Makefile
new file mode 100644
index 00000000..4ba0bffc
--- /dev/null
+++ b/testsuite/tests/lib-set/Makefile
@@ -0,0 +1,3 @@
+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
new file mode 100644
index 00000000..1197fbf6
--- /dev/null
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -0,0 +1,123 @@
+module M = Map.Make(struct type t = int let compare = compare end)
+
+let img x m = try Some(M.find x m) with Not_found -> None
+
+let testvals = [0;1;2;3;4;5;6;7;8;9]
+
+let check msg cond =
+  if not (List.for_all cond testvals) then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let checkbool msg b =
+  if not b then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let uncurry (f: 'a -> 'b -> 'c) (x, y: 'a * 'b) : 'c = f x y
+
+let test x v s1 s2 =
+
+  checkbool "is_empty"
+    (M.is_empty s1 = List.for_all (fun i -> img i s1 = None) testvals);
+
+  check "mem"
+    (fun i -> M.mem i s1 = (img i s1 <> None));
+
+  check "add"
+    (let s = M.add x v s1 in
+     fun i -> img i s = (if i = x then Some v else img i s1));
+
+  check "singleton"
+    (let s = M.singleton x v in
+     fun i -> img i s = (if i = x then Some v else None));
+
+  check "remove"
+    (let s = M.remove x s1 in
+     fun i -> img i s = (if i = x then None else img i s1));
+
+  check "merge-union"
+    (let f _ o1 o2 =
+       match o1, o2 with
+       | Some v1, Some v2 -> Some (v1 +. v2)
+       | None, _ -> o2
+       | _, None -> o1 in
+     let s = M.merge f s1 s2 in
+     fun i -> img i s = f i (img i s1) (img i s2));
+
+  check "merge-inter"
+    (let f _ o1 o2 =
+       match o1, o2 with
+       | Some v1, Some v2 -> Some (v1 -. v2)
+       | _, _ -> None in
+     let s = M.merge f s1 s2 in
+     fun i -> img i s = f i (img i s1) (img i s2));
+
+  checkbool "bindings"
+    (let rec extract = function
+       | [] -> []
+       | hd :: tl ->
+           match img hd s1 with
+           | None -> extract tl
+           | Some v ->(hd,  v) :: extract tl in
+     M.bindings s1 = extract testvals);
+
+  checkbool "for_all"
+    (let p x y = x mod 2 = 0 in
+     M.for_all p s1 = List.for_all (uncurry p) (M.bindings s1));
+
+  checkbool "exists"
+    (let p x y = x mod 3 = 0 in
+     M.exists p s1 = List.exists (uncurry p) (M.bindings s1));
+
+  checkbool "filter"
+    (let p x y = x >= 3 && x <= 6 in
+     M.bindings(M.filter p s1) = List.filter (uncurry p) (M.bindings s1));
+
+  checkbool "partition"
+    (let p x y = x >= 3 && x <= 6 in
+     let (st,sf) = M.partition p s1
+     and (lt,lf) = List.partition (uncurry p) (M.bindings s1) in
+     M.bindings st = lt && M.bindings sf = lf);
+
+  checkbool "cardinal"
+    (M.cardinal s1 = List.length (M.bindings s1));
+
+  checkbool "min_binding"
+    (try
+       let (k,v) = M.min_binding s1 in
+       img k s1 = Some v && M.for_all (fun i _ -> k <= i) s1
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "max_binding"
+    (try
+       let (k,v) = M.max_binding s1 in
+       img k s1 = Some v && M.for_all (fun i _ -> k >= i) s1
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "choose"
+    (try
+       let (x,v) = M.choose s1 in img x s1 = Some v
+     with Not_found ->
+       M.is_empty s1);
+
+  check "split"
+    (let (l, p, r) = M.split x s1 in
+     fun i -> 
+       if i < x then img i l = img i s1
+       else if i > x then img i r = img i s1
+       else p = img i s1)
+
+let rkey() = Random.int 10
+
+let rdata() = Random.float 1.0
+
+let rmap() =
+  let s = ref M.empty in
+  for i = 1 to Random.int 10 do s := M.add (rkey()) (rdata()) !s done;
+  !s
+
+let _ =
+  Random.init 42;
+  for i = 1 to 25000 do test (rkey()) (rdata()) (rmap()) (rmap()) done
+  
diff --git a/testsuite/tests/lib-set/testmap.reference b/testsuite/tests/lib-set/testmap.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
new file mode 100644
index 00000000..c4ab0441
--- /dev/null
+++ b/testsuite/tests/lib-set/testset.ml
@@ -0,0 +1,120 @@
+module S = Set.Make(struct type t = int let compare = compare end)
+
+let testvals = [0;1;2;3;4;5;6;7;8;9]
+
+let check msg cond =
+  if not (List.for_all cond testvals) then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let checkbool msg b =
+  if not b then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let normalize_cmp c =
+  if c = 0 then 0 else if c > 0 then 1 else -1
+
+let test x s1 s2 =
+
+  checkbool "is_empty"
+    (S.is_empty s1 = List.for_all (fun i -> not (S.mem i s1)) testvals);
+
+  check "add"
+    (let s = S.add x s1 in
+     fun i -> S.mem i s = (S.mem i s1 || i = x));
+
+  check "singleton"
+    (let s = S.singleton x in
+     fun i -> S.mem i s = (i = x));
+
+  check "remove"
+    (let s = S.remove x s1 in
+     fun i -> S.mem i s = (S.mem i s1 && i <> x));
+
+  check "union"
+    (let s = S.union s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 || S.mem i s2));
+
+  check "inter"
+    (let s = S.inter s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 && S.mem i s2));
+
+  check "diff"
+    (let s = S.diff s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 && not (S.mem i s2)));
+
+  checkbool "elements"
+    (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals);
+
+  checkbool "compare"
+    (normalize_cmp (S.compare s1 s2) = normalize_cmp (compare (S.elements s1) (S.elements s2)));
+
+  checkbool "equal"
+    (S.equal s1 s2 = (S.elements s1 = S.elements s2));
+
+  check "subset"
+    (let b = S.subset s1 s2 in
+     fun i -> if b && S.mem i s1 then S.mem i s2 else true);
+
+  checkbool "subset2"
+    (let b = S.subset s1 s2 in
+     b || not (S.is_empty (S.diff s1 s2)));
+
+  checkbool "for_all"
+    (let p x = x mod 2 = 0 in
+     S.for_all p s1 = List.for_all p (S.elements s1));
+
+  checkbool "exists"
+    (let p x = x mod 3 = 0 in
+     S.exists p s1 = List.exists p (S.elements s1));
+
+  checkbool "filter"
+    (let p x = x >= 3 && x <= 6 in
+     S.elements(S.filter p s1) = List.filter p (S.elements s1));
+
+  checkbool "partition"
+    (let p x = x >= 3 && x <= 6 in
+     let (st,sf) = S.partition p s1
+     and (lt,lf) = List.partition p (S.elements s1) in
+     S.elements st = lt && S.elements sf = lf);
+
+  checkbool "cardinal"
+    (S.cardinal s1 = List.length (S.elements s1));
+
+  checkbool "min_elt"
+    (try
+       let m = S.min_elt s1 in
+       S.mem m s1 && S.for_all (fun i -> m <= i) s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "max_elt"
+    (try
+       let m = S.max_elt s1 in
+       S.mem m s1 && S.for_all (fun i -> m >= i) s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "choose"
+    (try
+       let x = S.choose s1 in S.mem x s1
+     with Not_found ->
+       S.is_empty s1);
+
+  check "split"
+    (let (l, p, r) = S.split x s1 in
+     fun i -> 
+       if i < x then S.mem i l = S.mem i s1
+       else if i > x then S.mem i r = S.mem i s1
+       else p = S.mem i s1)
+
+let relt() = Random.int 10
+
+let rset() =
+  let s = ref S.empty in
+  for i = 1 to Random.int 10 do s := S.add (relt()) !s done;
+  !s
+
+let _ =
+  Random.init 42;
+  for i = 1 to 25000 do test (relt()) (rset()) (rset()) done
+  
diff --git a/testsuite/tests/lib-set/testset.reference b/testsuite/tests/lib-set/testset.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-str/Makefile b/testsuite/tests/lib-str/Makefile
index 530ea730..35ad3003 100644
--- a/testsuite/tests/lib-str/Makefile
+++ b/testsuite/tests/lib-str/Makefile
@@ -1,4 +1,5 @@
+BASEDIR=../..
 LIBRARIES=str
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-systhreads/Makefile b/testsuite/tests/lib-systhreads/Makefile
index 80138b26..8729461a 100644
--- a/testsuite/tests/lib-systhreads/Makefile
+++ b/testsuite/tests/lib-systhreads/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 LIBRARIES=unix threads
 ADD_COMPFLAGS=-thread
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-threads/.cvsignore b/testsuite/tests/lib-threads/.cvsignore
deleted file mode 100644
index e6d9e45b..00000000
--- a/testsuite/tests/lib-threads/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.byt
diff --git a/testsuite/tests/lib-threads/.ignore b/testsuite/tests/lib-threads/.ignore
new file mode 100644
index 00000000..e6d9e45b
--- /dev/null
+++ b/testsuite/tests/lib-threads/.ignore
@@ -0,0 +1 @@
+*.byt
diff --git a/testsuite/tests/lib-threads/Makefile b/testsuite/tests/lib-threads/Makefile
index 80138b26..8729461a 100644
--- a/testsuite/tests/lib-threads/Makefile
+++ b/testsuite/tests/lib-threads/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 LIBRARIES=unix threads
 ADD_COMPFLAGS=-thread
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc-kb/Makefile b/testsuite/tests/misc-kb/Makefile
index b5f5eaec..1802e554 100644
--- a/testsuite/tests/misc-kb/Makefile
+++ b/testsuite/tests/misc-kb/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 MODULES=terms equations orderings kb
 MAIN_MODULE=kbmain
 ADD_COMPFLAGS=-w a
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml
index a7ea9a03..5617bc4f 100644
--- a/testsuite/tests/misc-kb/equations.ml
+++ b/testsuite/tests/misc-kb/equations.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli
index 45d79026..0db190b8 100644
--- a/testsuite/tests/misc-kb/equations.mli
+++ b/testsuite/tests/misc-kb/equations.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml
index 590f4cd5..ff357b3f 100644
--- a/testsuite/tests/misc-kb/kb.ml
+++ b/testsuite/tests/misc-kb/kb.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli
index 59b60e4e..27aa2e98 100644
--- a/testsuite/tests/misc-kb/kb.mli
+++ b/testsuite/tests/misc-kb/kb.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml
index 0a5da2fb..580b7150 100644
--- a/testsuite/tests/misc-kb/kbmain.ml
+++ b/testsuite/tests/misc-kb/kbmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml
index 11a776ba..c81746e3 100644
--- a/testsuite/tests/misc-kb/orderings.ml
+++ b/testsuite/tests/misc-kb/orderings.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli
index d7abfd56..bb44f083 100644
--- a/testsuite/tests/misc-kb/orderings.mli
+++ b/testsuite/tests/misc-kb/orderings.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml
index dba70006..86604f9c 100644
--- a/testsuite/tests/misc-kb/terms.ml
+++ b/testsuite/tests/misc-kb/terms.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli
index 7d22e9cb..0f6be4c8 100644
--- a/testsuite/tests/misc-kb/terms.mli
+++ b/testsuite/tests/misc-kb/terms.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-unsafe/Makefile b/testsuite/tests/misc-unsafe/Makefile
index 82f7a72d..f4a8b4e3 100644
--- a/testsuite/tests/misc-unsafe/Makefile
+++ b/testsuite/tests/misc-unsafe/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 UNSAFE=ON
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc-unsafe/almabench.ml b/testsuite/tests/misc-unsafe/almabench.ml
index b2130472..73293e9a 100644
--- a/testsuite/tests/misc-unsafe/almabench.ml
+++ b/testsuite/tests/misc-unsafe/almabench.ml
@@ -1,6 +1,6 @@
 (*
  * ALMABENCH 1.0.1
- * Objective Caml version
+ *      OCaml     version
  *
  *     A number-crunching benchmark designed for cross-language and vendor
  *     comparisons.
diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml
index 0907cdee..f0a2ed32 100644
--- a/testsuite/tests/misc-unsafe/fft.ml
+++ b/testsuite/tests/misc-unsafe/fft.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml
index 7449488d..d5d8fb4d 100644
--- a/testsuite/tests/misc-unsafe/quicksort.ml
+++ b/testsuite/tests/misc-unsafe/quicksort.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
index aba79b15..16393986 100644
--- a/testsuite/tests/misc-unsafe/soli.ml
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/Makefile b/testsuite/tests/misc/Makefile
index a226dd11..4ba0bffc 100644
--- a/testsuite/tests/misc/Makefile
+++ b/testsuite/tests/misc/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+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 8452b8c6..b2a3d705 100644
--- a/testsuite/tests/misc/bdd.ml
+++ b/testsuite/tests/misc/bdd.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-(* Translated to Caml by Xavier Leroy *)
+(* Translated to OCaml by Xavier Leroy *)
 (* Original code written in SML by ... *)
 
 type bdd = One | Zero | Node of bdd * int * int * bdd
diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml
index c5e829ff..4f4e0813 100644
--- a/testsuite/tests/misc/boyer.ml
+++ b/testsuite/tests/misc/boyer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml
index 7fad4bfd..4160004e 100644
--- a/testsuite/tests/misc/fib.ml
+++ b/testsuite/tests/misc/fib.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/hamming.ml b/testsuite/tests/misc/hamming.ml
index 7216ddb0..87245440 100644
--- a/testsuite/tests/misc/hamming.ml
+++ b/testsuite/tests/misc/hamming.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml
index e3adfd62..b35360a8 100644
--- a/testsuite/tests/misc/nucleic.ml
+++ b/testsuite/tests/misc/nucleic.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml
index 994a4087..7f0295bb 100644
--- a/testsuite/tests/misc/sieve.ml
+++ b/testsuite/tests/misc/sieve.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml
index 8e49f248..8f9400eb 100644
--- a/testsuite/tests/misc/takc.ml
+++ b/testsuite/tests/misc/takc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml
index 555fb01c..31e617ee 100644
--- a/testsuite/tests/misc/taku.ml
+++ b/testsuite/tests/misc/taku.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/testsuite/tests/prim-revapply/Makefile b/testsuite/tests/prim-revapply/Makefile
new file mode 100644
index 00000000..bcc2fdb0
--- /dev/null
+++ b/testsuite/tests/prim-revapply/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
new file mode 100644
index 00000000..1a169e18
--- /dev/null
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -0,0 +1,36 @@
+external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      f @@ 3; (* 6 *)
+      g @@ f @@ 3; (* 36 *)
+      f @@ g @@ 3; (* 18 *)
+      h @@ g @@ f @@ 3; (* 37 *)
+      add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
+    ]
+external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      f @@ 3; (* 6 *)
+      g @@ f @@ 3; (* 36 *)
+      f @@ g @@ 3; (* 18 *)
+      h @@ g @@ f @@ 3; (* 37 *)
+      add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
+    ]
diff --git a/testsuite/tests/prim-revapply/apply.reference b/testsuite/tests/prim-revapply/apply.reference
new file mode 100644
index 00000000..07fc0dc4
--- /dev/null
+++ b/testsuite/tests/prim-revapply/apply.reference
@@ -0,0 +1,10 @@
+6
+36
+18
+37
+260
+6
+36
+18
+37
+260
diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
new file mode 100644
index 00000000..f8b0dc2e
--- /dev/null
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -0,0 +1,18 @@
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      3 |> f; (* 6 *)
+      3 |> f |> g; (* 36 *)
+      3 |> g |> f; (* 18 *)
+      3 |> f |> g |> h; (* 37 *)
+      3 |> add 2 |> add 3 |> f |> g |> add 4; (* 260 *)
+    ]
diff --git a/testsuite/tests/prim-revapply/revapply.reference b/testsuite/tests/prim-revapply/revapply.reference
new file mode 100644
index 00000000..fbca4428
--- /dev/null
+++ b/testsuite/tests/prim-revapply/revapply.reference
@@ -0,0 +1,5 @@
+6
+36
+18
+37
+260
diff --git a/testsuite/tests/regression-camlp4-class-type-plus/Makefile b/testsuite/tests/regression-camlp4-class-type-plus/Makefile
deleted file mode 100644
index 95106ce6..00000000
--- a/testsuite/tests/regression-camlp4-class-type-plus/Makefile
+++ /dev/null
@@ -1,5 +0,0 @@
-ADD_COMPFLAGS = -pp 'camlp4o'
-MAIN_MODULE = camlp4_class_type_plus_ok
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
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
deleted file mode 100644
index 79ba26d8..00000000
--- a/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-type t;;
-type xdr_value;;
-
-class type [ 't ] engine = object
-end;;
-
-module type T = sig
-class unbound_async_call : t -> [xdr_value] engine;;
-end;;
diff --git a/testsuite/tests/regression-pr5080-notes/Makefile b/testsuite/tests/regression-pr5080-notes/Makefile
deleted file mode 100644
index 149c289b..00000000
--- a/testsuite/tests/regression-pr5080-notes/Makefile
+++ /dev/null
@@ -1,5 +0,0 @@
-ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
-MAIN_MODULE = pr5080_notes_ok
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml
deleted file mode 100644
index 175bc8b7..00000000
--- a/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml
+++ /dev/null
@@ -1,4 +0,0 @@
-let marshal_int f  =
-  match [] with
-  | _ :: `INT n :: _ -> f n
-  | _ -> failwith "marshal_int"
diff --git a/testsuite/tests/regression/camlp4-class-type-plus/Makefile b/testsuite/tests/regression/camlp4-class-type-plus/Makefile
new file mode 100644
index 00000000..a539d51a
--- /dev/null
+++ b/testsuite/tests/regression/camlp4-class-type-plus/Makefile
@@ -0,0 +1,5 @@
+ADD_COMPFLAGS = -pp 'camlp4o'
+MAIN_MODULE = camlp4_class_type_plus_ok
+
+include ../../../makefiles/Makefile.okbad
+include ../../../makefiles/Makefile.common
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
new file mode 100644
index 00000000..79ba26d8
--- /dev/null
+++ b/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
@@ -0,0 +1,9 @@
+type t;;
+type xdr_value;;
+
+class type [ 't ] engine = object
+end;;
+
+module type T = sig
+class unbound_async_call : t -> [xdr_value] engine;;
+end;;
diff --git a/testsuite/tests/regression/pr5080-notes/Makefile b/testsuite/tests/regression/pr5080-notes/Makefile
new file mode 100644
index 00000000..ddc4d552
--- /dev/null
+++ b/testsuite/tests/regression/pr5080-notes/Makefile
@@ -0,0 +1,5 @@
+ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
+MAIN_MODULE = pr5080_notes_ok
+
+include ../../../makefiles/Makefile.okbad
+include ../../../makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
new file mode 100644
index 00000000..175bc8b7
--- /dev/null
+++ b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
@@ -0,0 +1,4 @@
+let marshal_int f  =
+  match [] with
+  | _ :: `INT n :: _ -> f n
+  | _ -> failwith "marshal_int"
diff --git a/testsuite/tests/runtime-errors/.ignore b/testsuite/tests/runtime-errors/.ignore
new file mode 100644
index 00000000..fa628eaa
--- /dev/null
+++ b/testsuite/tests/runtime-errors/.ignore
@@ -0,0 +1 @@
+*.bytecode
diff --git a/testsuite/tests/runtime-errors/.svnignore b/testsuite/tests/runtime-errors/.svnignore
deleted file mode 100755
index ceeffd0d..00000000
--- a/testsuite/tests/runtime-errors/.svnignore
+++ /dev/null
@@ -1,11 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < $$f.result 2>&1; true); \
-	  diff -q $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
-	  printf " ... testing '`basename $$f bytecode`native':"; \
-	  (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \
-	  diff -q `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
+	  $(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"; \
+	  fi; \
 	done
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.bytecode *.native *.result
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
index 745f81ae..a5bbdea3 100644
--- a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
+++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
@@ -1,5 +1,4 @@
-x = 196608
-x = 131072
-x = 65536
+x = 20000
+x = 10000
 x = 0
 Stack overflow caught
diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
index 4d211bc8..ab53b8b0 100644
--- a/testsuite/tests/runtime-errors/stackoverflow.ml
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -1,5 +1,5 @@
 let rec f x =
-  if x land 0xFFFF <> 0
+  if not (x = 0 || x = 10000 || x = 20000)
   then 1 + f (x + 1)
   else
     try
diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.reference b/testsuite/tests/runtime-errors/stackoverflow.native.reference
index 835095c5..a5bbdea3 100644
--- a/testsuite/tests/runtime-errors/stackoverflow.native.reference
+++ b/testsuite/tests/runtime-errors/stackoverflow.native.reference
@@ -1,65 +1,4 @@
-x = 4128768
-x = 4063232
-x = 3997696
-x = 3932160
-x = 3866624
-x = 3801088
-x = 3735552
-x = 3670016
-x = 3604480
-x = 3538944
-x = 3473408
-x = 3407872
-x = 3342336
-x = 3276800
-x = 3211264
-x = 3145728
-x = 3080192
-x = 3014656
-x = 2949120
-x = 2883584
-x = 2818048
-x = 2752512
-x = 2686976
-x = 2621440
-x = 2555904
-x = 2490368
-x = 2424832
-x = 2359296
-x = 2293760
-x = 2228224
-x = 2162688
-x = 2097152
-x = 2031616
-x = 1966080
-x = 1900544
-x = 1835008
-x = 1769472
-x = 1703936
-x = 1638400
-x = 1572864
-x = 1507328
-x = 1441792
-x = 1376256
-x = 1310720
-x = 1245184
-x = 1179648
-x = 1114112
-x = 1048576
-x = 983040
-x = 917504
-x = 851968
-x = 786432
-x = 720896
-x = 655360
-x = 589824
-x = 524288
-x = 458752
-x = 393216
-x = 327680
-x = 262144
-x = 196608
-x = 131072
-x = 65536
+x = 20000
+x = 10000
 x = 0
 Stack overflow caught
diff --git a/testsuite/tests/tool-lexyacc/.ignore b/testsuite/tests/tool-lexyacc/.ignore
new file mode 100644
index 00000000..6bcc8514
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/.ignore
@@ -0,0 +1,3 @@
+scanner.ml
+grammar.mli
+grammar.ml
diff --git a/testsuite/tests/tool-lexyacc/.svnignore b/testsuite/tests/tool-lexyacc/.svnignore
deleted file mode 100644
index 36706006..00000000
--- a/testsuite/tests/tool-lexyacc/.svnignore
+++ /dev/null
@@ -1,13 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < 196799 then raise Not_found;;
+if Hashtbl.hash_param 5 6 [1;2;3] <> 697606130 then raise Not_found;;
 
 (**
        0 CONSTINT 42
diff --git a/testsuite/tests/tool-ocamldoc/.ignore b/testsuite/tests/tool-ocamldoc/.ignore
new file mode 100644
index 00000000..866d4be8
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/.ignore
@@ -0,0 +1,4 @@
+*.html
+*.sty
+*.css
+ocamldoc.out
diff --git a/testsuite/tests/tool-ocamldoc/.svnignore b/testsuite/tests/tool-ocamldoc/.svnignore
deleted file mode 100755
index eee23b68..00000000
--- a/testsuite/tests/tool-ocamldoc/.svnignore
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+	  $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \
+	  $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
 	done;
-	@$(OCAMLDOC) -html t*.ml 2>&1 | grep -v test_types_display || true
-	@$(OCAMLDOC) -latex t*.ml 2>&1 | grep -v test_types_display || true
+	@$(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
 
+promote: defaultpromote
 
 clean: defaultclean
 	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml
index ba73fe52..b5cc5562 100644
--- a/testsuite/tests/tool-ocamldoc/odoc_test.ml
+++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml
@@ -88,7 +88,7 @@ class string_gen =
       true
 
     method generate (module_list: Odoc_info.Module.t_module list) =
-      let oc = open_out !Odoc_info.Args.out_file in
+      let oc = open_out !Odoc_info.Global.out_file in
       fmt <- Format.formatter_of_out_channel oc;
       (
        try
@@ -106,7 +106,12 @@ class string_gen =
       close_out oc
   end
 
-
-let my_generator = new string_gen
-let _ = Odoc_info.Args.set_doc_generator 
-    (Some (my_generator :> Odoc_info.Args.doc_generator))
+let _ =
+  let module My_generator = struct
+    class generator =
+    let inst = new string_gen in
+    object
+      method generate = inst#generate
+    end
+  end in
+  Odoc_args.set_generator (Odoc_gen.Base (module My_generator : Odoc_gen.Base))
diff --git a/testsuite/tests/typing-fstclassmod/.svnignore b/testsuite/tests/typing-fstclassmod/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/typing-fstclassmod/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+;;
+
+(* Tagging data *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+ 
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+ 
+exception VariantMismatch
+ 
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | _ -> raise VariantMismatch
+;;
+
+(* Handling records *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: 'a record -> 'a ty
+ 
+and 'a record =
+    {
+     path: string;
+     fields: 'a field_ list;
+    }
+ 
+and 'a field_ =
+  | Field: ('a, 'b) field -> 'a field_
+ 
+and ('a, 'b) field =
+    {
+     label: string;
+     field_type: 'b ty;
+     get: ('a -> 'b);
+    }
+;;
+
+(* Again *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+    | Record {fields} ->
+        VRecord
+          (List.map (fun (Field{field_type; label; get}) ->
+                       (label, variantize field_type (get x))) fields)
+;;
+ 
+(* Extraction *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: ('a, 'builder) record -> 'a ty
+ 
+and ('a, 'builder) record =
+    {
+     path: string;
+     fields: ('a, 'builder) field list;
+     create_builder: (unit -> 'builder);
+     of_builder: ('builder -> 'a);
+    }
+ 
+and ('a, 'builder) field =
+  | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+ 
+and ('a, 'builder, 'b) field_ =
+  {
+   label: string;
+   field_type: 'b ty;
+   get: ('a -> 'b);
+   set: ('builder -> 'b -> unit);
+  }
+ 
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | Record {fields; create_builder; of_builder}, VRecord fl ->
+        if List.length fields <> List.length fl then raise VariantMismatch;
+        let builder = create_builder () in
+        List.iter2
+          (fun (Field {label; field_type; set}) (lab, v) ->
+            if label <> lab then raise VariantMismatch;
+            set builder (devariantize field_type v)
+          )
+          fields fl;
+        of_builder builder
+    | _ -> raise VariantMismatch
+;;
+
+type my_record  =
+    {
+     a: int;
+     b: string list;
+    }
+ 
+let my_record =
+  let fields =
+    [
+     Field {label = "a"; field_type = Int;
+            get = (fun {a} -> a);
+            set = (fun (r, _) x -> r := Some x)};
+     Field {label = "b"; field_type = List String;
+            get = (fun {b} -> b);
+            set = (fun (_, r) x -> r := Some x)};
+    ]
+  in
+  let create_builder () = (ref None, ref None) in
+  let of_builder (a, b) =
+    match !a, !b with
+    | Some a, Some b -> {a; b}
+    | _ -> failwith "Some fields are missing in record of type my_record"
+  in
+  Record {path = "My_module.my_record"; fields; create_builder; of_builder}
+;;
+
+(* Extension to recursive types and polymorphic variants *)
+(* by Jacques Garrigue *)
+
+type noarg = Noarg
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  (* Support for type variables and recursive types *)
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  (* Change the representation of a type *)
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  (* Sum types (both normal sums and polymorphic variants) *)
+  | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+
+and ('a, 'e, 'b) ty_sum =
+    { sum_proj: 'a -> string * 'e ty_dyn option;
+      sum_cases: (string * ('e,'b) ty_case) list;
+      sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; }
+
+and 'e ty_dyn =              (* dynamic type *)
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =           (* selector from a list of types *)
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =          (* type a sum case *)
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+type _ ty_env =              (* type variable substitution *)
+  | Enil : unit ty_env
+  | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+;;
+
+(* Comparing selectors *)
+type (_,_) eq = Eq: ('a,'a) eq
+
+let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
+  fun s1 s2 ->
+    match s1, s2 with
+    | Thd, Thd -> Some Eq
+    | Ttl s1, Ttl s2 ->
+        (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
+    | _ -> None
+
+(* Auxiliary function to get the type of a case from its selector *)
+let rec get_case : type a b e.
+  (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option =
+  fun sel cases ->
+  match cases with
+  | (name, TCnoarg sel') :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, None
+      end
+  | (name, TCarg (sel', ty)) :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, Some ty
+      end
+  | [] -> raise Not_found
+;;
+
+(* Untyped representation of values *)
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+
+let may_map f = function Some x -> Some (f x) | None -> None
+
+let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
+  fun e ty v ->
+  match ty with
+  | Int -> VInt v
+  | String -> VString v
+  | List t -> VList (List.map (variantize e t) v)
+  | Option t -> VOption (may_map (variantize e t) v)
+  | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v))
+  | Rec t -> variantize (Econs (ty, e)) t v
+  | Pop t -> (match e with Econs (_, e') -> variantize e' t v)
+  | Var -> (match e with Econs (t, e') -> variantize e' t v)
+  | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v))
+  | Sum ops ->
+      let tag, arg = ops.sum_proj v in
+      VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
+;;
+
+let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
+  fun e ty v ->
+  match ty, v with
+  | Int, VInt x -> x
+  | String, VString x -> x
+  | List ty1, VList vl ->
+      List.map (devariantize e ty1) vl
+  | Pair (ty1, ty2), VPair (x1, x2) ->
+      (devariantize e ty1 x1, devariantize e ty2 x2)
+  | Rec t, _ -> devariantize (Econs (ty, e)) t v
+  | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v)
+  | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v)
+  | Conv (s, proj, inj, t), VConv (s', v) when s = s' ->
+      inj (devariantize e t v)
+  | Sum ops, VSum (tag, a) ->
+      begin try match List.assoc tag ops.sum_cases, a with
+      | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a)
+      | TCnoarg sel, None -> ops.sum_inj (sel, Noarg)
+      | _ -> raise VariantMismatch
+      with Not_found -> raise VariantMismatch
+      end
+  | _ -> raise VariantMismatch
+;;
+
+(* First attempt: represent 1-constructor variants using Conv *)
+let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+
+let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+let v = variantize Enil (ty Int);;
+let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+
+(* Can also use it to decompose a tuple *)
+
+let triple t1 t2 t3 =
+  Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+
+let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+
+(* Second attempt: introduce a real sum construct *)
+let ty_abc =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  let proj = function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None
+  (* Define inj in advance to be able to write the type annotation easily *)
+  and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c ->
+    [`A of int | `B of string | `C] = function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  in
+  (* Coherence of sum_inj and sum_cases is checked by the typing *)
+  Sum { sum_proj = proj; sum_inj = inj; sum_cases =
+        [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+          "C", TCnoarg (Ttl (Ttl Thd)) ] }
+;;
+
+let v = variantize Enil ty_abc (`A 3)
+let a = devariantize Enil ty_abc v
+
+(* And an example with recursion... *)
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum {
+       sum_proj = (function
+           `Nil -> "Nil", None
+         | `Cons p -> "Cons", Some (Tdyn (tcons, p)));
+       sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)];
+       sum_inj = fun (type c) ->
+         (function
+         | Thd, Noarg -> `Nil
+         | Ttl Thd, v -> `Cons v
+         : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
+         (* One can also write the type annotation directly *)
+     })
+
+let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
+
+
+(* Simpler but weaker approach *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a)
+             -> ('a, 'e) ty
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+let ty_abc : ([`A of int | `B of string | `C],'e) ty =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  Sum (
+  (function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None),
+  (function
+      "A", Some (Tdyn (Int, n)) -> `A n
+    | "B", Some (Tdyn (String, s)) -> `B s
+    | "C", None -> `C
+    | _ -> invalid_arg "ty_abc"))
+;;
+
+(* Breaks: no way to pattern-match on a full recursive type *)
+let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
+  let targ = Pair (Pop t, Var) in
+  Rec (Sum (
+  (function `Nil -> "Nil", None
+    | `Cons p -> "Cons", Some (Tdyn (targ, p))),
+  (function "Nil", None -> `Nil
+    | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+;;
+
+(* Define Sum using object instead of record for first-class polymorphism *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: < proj: 'a -> string * 'e ty_dyn option;
+           cases: (string * ('e,'b) ty_case) list;
+           inj: 'c. ('b,'c) ty_sel * 'c -> 'a >
+          -> ('a, 'e) ty
+
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
+  Sum (object
+    method proj = function
+        `A n -> "A", Some (Tdyn (Int, n))
+      | `B s -> "B", Some (Tdyn (String, s))
+      | `C -> "C", None
+    method cases =
+      [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+        "C", TCnoarg (Ttl (Ttl Thd)) ];
+    method inj : type c.
+        (int -> string -> noarg -> unit, c) ty_sel * c ->
+          [`A of int | `B of string | `C] =
+      function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+      | _ -> assert false
+  end)
+
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum (object
+    method proj = function
+        `Nil -> "Nil", None
+      | `Cons p -> "Cons", Some (Tdyn (tcons, p))
+    method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]
+    method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist
+    = function
+      | Thd, Noarg -> `Nil
+      | Ttl Thd, v -> `Cons v
+  end))
+;;
+
+(*
+type (_,_) ty_assoc =
+  | Anil : (unit,'e) ty_assoc
+  | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc
+
+and (_,_) ty_pvar =
+  | Pnil : ('a,'e) ty_pvar
+  | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar
+  | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar
+*)
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
new file mode 100644
index 00000000..72a301c4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
@@ -0,0 +1,176 @@
+
+#                       type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+#                                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = 
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = 
+#                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+#                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = 
+#                                                                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = 
+#                                                   type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = ; set = };
+      Field {label = "b"; field_type = List String; get = ; set = }];
+    create_builder = ; of_builder = }
+#                                                                         type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#         type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+#                                                         type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = 
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = 
+#                                                         type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = 
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = 
+#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = 
+#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = 
+#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  
+# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = 
+# val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+#               val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = 
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = ;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = }
+#                                             val a : [ `A of int | `B of string | `C ] = `A 3
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+#                                                               type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
+#                   Characters 327-344:
+      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+                                           ^^^^^^^^^^^^^^^^^
+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
+#                                                         type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#                                                                     val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum 
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+#   * * * * * * * * *   
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
new file mode 100644
index 00000000..72a301c4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
@@ -0,0 +1,176 @@
+
+#                       type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+#                                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = 
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = 
+#                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+#                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = 
+#                                                                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = 
+#                                                   type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = ; set = };
+      Field {label = "b"; field_type = List String; get = ; set = }];
+    create_builder = ; of_builder = }
+#                                                                         type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#         type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+#                                                         type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = 
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = 
+#                                                         type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = 
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = 
+#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = 
+#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = 
+#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  
+# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = 
+# val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+#               val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = 
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = ;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = }
+#                                             val a : [ `A of int | `B of string | `C ] = `A 3
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+#                                                               type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
+#                   Characters 327-344:
+      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+                                           ^^^^^^^^^^^^^^^^^
+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
+#                                                         type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#                                                                     val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum 
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+#   * * * * * * * * *   
diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
new file mode 100644
index 00000000..cddfe460
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -0,0 +1,779 @@
+(*
+   An attempt at encoding omega examples from the 2nd Central European
+   Functional Programming School:
+     Generic Programming in Omega, by Tim Sheard and Nathan Linger
+          http://web.cecs.pdx.edu/~sheard/
+*)
+
+(* Basic types *)
+
+type ('a,'b) sum = Inl of 'a | Inr of 'b
+
+type zero = Zero
+type _ succ
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+;;
+
+(* 2: A simple example *)
+
+type (_,_) seq =
+  | Snil  : ('a,zero) seq
+  | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq
+;;
+
+let l1 = Scons (3, Scons (5, Snil)) ;;
+
+(* We do not have type level functions, so we need to use witnesses. *)
+(* We copy here the definitions from section 3.9 *)
+(* Note the addition of the ['a nat] argument to PlusZ, since we do not
+   have kinds *)
+type (_,_,_) plus =
+  | PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus
+;;
+
+let rec length : type a n. (a,n) seq -> n nat = function
+  | Snil -> NZ
+  | Scons (_, s) -> NS (length s)
+;;
+
+(* app returns the catenated lists with a witness proving that
+   the size is the sum of its two inputs *)
+type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app
+
+let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
+  fun xs ys ->
+  match xs with
+  | Snil -> App (ys, PlusZ (length ys))
+  | Scons (x, xs') ->
+      match app xs' ys with
+      | App (xs'', pl) -> App (Scons (x, xs''), PlusS pl)
+;;
+(* Note: it would be nice to be able to handle existentials in
+   let definitions *)
+
+(* 3.1 Feature: kinds *)
+
+(* We do not have kinds, but we can encode them as predicates *)
+
+type tp
+type nd
+type (_,_) fk
+type _ shape =
+  | Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
+;;
+type tt
+type ff
+type _ boolean =
+  | BT : tt boolean
+  | BF : ff boolean
+;;
+
+(* 3.3 Feature : GADTs *)
+
+type (_,_) path =
+  | Pnone : 'a -> (tp,'a) path
+  | Phere : (nd,'a) path
+  | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path
+  | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path
+;;
+type (_,_) tree =
+  | Ttip  : (tp,'a) tree
+  | Tnode : 'a -> (nd,'a) tree
+  | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree
+;;
+let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+;;
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
+  = fun eq n t ->
+    match t with
+    | Ttip -> []
+    | Tnode m ->
+        if eq n m then [Phere] else []
+    | Tfork (x, y) ->
+        List.map (fun x -> Pleft x) (find eq n x) @
+        List.map (fun x -> Pright x) (find eq n y)
+;;
+let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
+  match (p, t) with
+  | Pnone x, Ttip -> x
+  | Phere, Tnode y -> y
+  | Pleft p, Tfork(l,_) -> extract p l
+  | Pright p, Tfork(_,r) -> extract p r
+;;
+
+(* 3.4 Pattern : Witness *)
+
+type (_,_) le =
+  | LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+;;
+type _ even =
+  | EvenZ : zero even
+  | EvenSS : 'n even -> 'n succ succ even
+;;
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+;;
+let even0 : zero even = EvenZ
+let even2 : two even = EvenSS EvenZ
+let even4 : four even = EvenSS (EvenSS EvenZ)
+;;
+let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+;;
+let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
+  match p with
+  | PlusZ n -> LeZ n
+  | PlusS p' -> LeS (summandLessThanSum p')
+;;
+
+(* 3.8 Pattern: Leibniz Equality *)
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+
+let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
+  match a, b with
+  | NZ, NZ -> Some Eq
+  | NS a', NS b' ->
+      begin match sameNat a' b' with
+      | Some Eq -> Some Eq
+      | None -> None
+      end
+  | _ -> None
+;;
+
+(* 3.9 Computing Programs and Properties Simultaneously *)
+
+(* Plus and app1 are moved to section 2 *)
+
+let smaller : type a b. (a succ, b succ) le -> (a,b) le =
+  function LeS x -> x ;;
+
+type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
+
+(*
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b, le with
+  | NZ, m, _ -> Diff (m, PlusZ m)
+  | NS x, NZ, _ -> assert false
+  | NS x, NS y, q ->
+      match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+*)
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match le, a, b with
+  | LeZ _, _, m -> Diff (m, PlusZ m)
+  | LeS q, NS x, NS y ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b,le with (* warning *)
+  | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+  | NS x, NS y, LeS q ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
+  fun le b ->
+  match b,le with
+  | m, LeZ _ -> Diff (m, PlusZ m)
+  | NS y, LeS q ->
+      match diff q y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
+
+let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
+  | LeZ n -> LeZ (NS n)
+  | LeS le -> LeS (leS' le)
+;;
+
+let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
+  fun f s ->
+  match s with
+  | Snil -> Filter (LeZ NZ, Snil)
+  | Scons (a,l) ->
+      match filter f l with Filter (le, l') ->
+        if f a then Filter (LeS le, Scons (a, l'))
+        else Filter (leS' le, l')
+;;
+
+(* 4.1 AVL trees *)
+
+type (_,_,_) balance =
+  | Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+
+type _ avl =
+  | Leaf : zero avl
+  | Node :
+      ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl
+
+type avl' = Avl : 'h avl -> avl'
+;;
+
+let empty = Avl Leaf
+
+let rec elem : type h. int -> h avl -> bool = fun x t ->
+  match t with
+  | Leaf -> false
+  | Node (_, l, y, r) ->
+      x = y || if x < y then elem x l else elem x r
+;;
+
+let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL y tR ->
+  match tL with
+  | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR)))
+  | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR)))
+  | Node (Less, a, x, Node (Same, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (Less, b, z, c)) ->
+      Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (More, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
+;;
+let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL u tR ->
+  match tR with
+  | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b))
+  | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b))
+  | Node (More, Node (Same, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (Less, a, x, b), y, c) ->
+      Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (More, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
+;;
+let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
+  fun x t ->
+  match t with
+  | Leaf -> Inr (Node (Same, Leaf, x, Leaf))
+  | Node (bal, a, y, b) ->
+      if x = y then Inl t else
+      if x < y then begin
+        match ins x a with
+        | Inl a -> Inl (Node (bal, a, y, b))
+        | Inr a ->
+            match bal with
+            | Less -> Inl (Node (Same, a, y, b))
+            | Same -> Inr (Node (More, a, y, b))
+            | More -> rotr a y b
+      end else begin
+        match ins x b with
+        | Inl b -> Inl (Node (bal, a, y, b) : n avl)
+        | Inr b ->
+            match bal with
+            | More -> Inl (Node (Same, a, y, b) : n avl)
+            | Same -> Inr (Node (Less, a, y, b) : n succ avl)
+            | Less -> rotl a y b
+      end
+;;
+
+let insert x (Avl t) =
+  match ins x t with
+  | Inl t -> Avl t
+  | Inr t -> Avl t
+;;
+
+let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
+  function
+  | Node (Less, Leaf, x, r) -> (x, Inl r)
+  | Node (Same, Leaf, x, r) -> (x, Inl r)
+  | Node (bal, (Node _ as l) , x, r) ->
+      match del_min l with
+      | y, Inr l -> (y, Inr (Node (bal, l, x, r)))
+      | y, Inl l ->
+          (y, match bal with
+          | Same -> Inr (Node (Less, l, x, r))
+          | More -> Inl (Node (Same, l, x, r))
+          | Less -> rotl l x r)
+
+type _ avl_del =
+  | Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+
+let rec del : type n. int -> n avl -> n avl_del = fun y t ->
+  match t with
+  | Leaf -> Dsame Leaf
+  | Node (bal, l, x, r) ->
+      if x = y then begin
+        match r with
+        | Leaf ->
+            begin match bal with
+            | Same -> Ddecr (Eq, l)
+            | More -> Ddecr (Eq, l)
+            end
+        | Node _ ->
+            begin match bal, del_min r with
+            | _, (z, Inr r) -> Dsame (Node (bal, l, z, r))
+            | Same, (z, Inl r) -> Dsame (Node (More, l, z, r))
+            | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r))
+            | More, (z, Inl r) ->
+                match rotr l z r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else if y < x then begin
+        match del y l with
+        | Dsame l -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,l) ->
+            begin match bal with
+            | Same -> Dsame (Node (Less, l, x, r))
+            | More -> Ddecr (Eq, Node (Same, l, x, r))
+            | Less ->
+                match rotl l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else begin
+        match del y r with
+        | Dsame r -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,r) ->
+            begin match bal with
+            | Same -> Dsame (Node (More, l, x, r))
+            | Less -> Ddecr (Eq, Node (Same, l, x, r))
+            | More ->
+                match rotr l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end
+;;
+
+let delete x (Avl t) =
+  match del x t with
+  | Dsame t -> Avl t
+  | Ddecr (_, t) -> Avl t
+;;
+
+
+(* Exercise 22: Red-black trees *)
+
+type red
+type black
+type (_,_) sub_tree =
+  | Bleaf : (black, zero) sub_tree
+  | Rnode :
+      (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode :
+      ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+;;
+
+type dir = LeftD | RightD
+
+type (_,_) ctxt =
+  | CNil : (black,'n) ctxt
+  | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt
+  | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt
+;;
+
+let blacken = function
+    Rnode (l, e, r) -> Bnode (l, e, r)
+
+type _ crep =
+  | Red : red crep
+  | Black : black crep
+
+let color : type c n. (c,n) sub_tree -> c crep = function
+  | Bleaf -> Black
+  | Rnode _ -> Red
+  | Bnode _ -> Black
+;;
+
+let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
+  fun ct t ->
+  match ct with
+  | CNil -> Root t
+  | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t))
+  | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle))
+  | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
+  | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
+;;
+let recolor d1 pE sib d2 gE uncle t =
+  match d1, d2 with
+  | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
+  | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle)
+  | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
+  | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
+;;
+let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
+  match d1, d2 with
+  | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
+  | LeftD,  RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle))
+  | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
+  | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
+;;
+let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun t ct ->
+  match ct with
+  | CNil -> Root (blacken t)
+  | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t))
+  | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib))
+  | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) ->
+      match color uncle with
+      | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
+      | Black -> fill ct (rotate dir e sib dir' e' uncle t)
+;;
+let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun e t ct ->
+  match t with
+  | Rnode (l, e', r) ->
+      if e < e' then ins e l (CRed (e', RightD, r, ct))
+                else ins e r (CRed (e', LeftD, l, ct))
+  | Bnode (l, e', r) ->
+      if e < e' then ins e l (CBlk (e', RightD, r, ct))
+                else ins e r (CBlk (e', LeftD, l, ct))
+  | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
+;;
+let insert e (Root t) = ins e t CNil
+;;
+
+(* 5.7 typed object languages using GADTs *)
+
+type _ term =
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let ex1 = Ap (Add, Pair (Const 3, Const 5))
+let ex2 = Pair (ex1, Const 1)
+
+let rec eval_term : type a. a term -> a = function
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x eval_term f (eval_term x)
+  | Pair(x,y) -> (eval_term x, eval_term y)
+
+type _ rep =
+  | Rint  : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun  : 'a rep * 'b rep -> ('a -> 'b) rep
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
+  fun ra rb ->
+  match ra, rb with
+  | Rint, Rint -> Some Eq
+  | Rbool, Rbool -> Some Eq
+  | Rpair (a1, a2), Rpair (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | Rfun (a1, a2), Rfun (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | _ -> None
+;;
+
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+
+let rec assoc : type a. string -> a rep -> assoc list -> a =
+  fun x r -> function
+  | [] -> raise Not_found
+  | Assoc (x', r', v) :: env ->
+      if x = x' then
+        match rep_equal r r' with
+        | None -> failwith ("Wrong type for " ^ x)
+        | Some Eq -> v
+      else assoc x r env
+
+type _ term =
+  | Var   : string * 'a rep -> 'a term
+  | Abs   : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let rec eval_term : type a. assoc list -> a term -> a =
+  fun env -> function
+  | Var (x, r) -> assoc x r env
+  | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x eval_term env f (eval_term env x)
+  | Pair(x,y) -> (eval_term env x, eval_term env y)
+;;
+
+let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
+let ex4 = Ap (ex3, Const 3)
+
+let v4 = eval_term [] ex4
+;;
+
+(* 5.9/5.10 Language with binding *)
+
+type rnil
+type (_,_,_) rcons
+
+type _ is_row =
+  | Rnil  : rnil is_row
+  | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row
+
+type (_,_) lam =
+  | Const : int -> ('e, int) lam
+  | Var : 'a -> (('a,'t,'e) rcons, 't) lam
+  | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam
+  | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+
+type x = X
+type y = Y
+
+let ex1 = App (Var X, Shift (Var Y))
+let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
+;;
+
+type _ env =
+  | Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+
+let rec eval_lam : type e t. e env -> (e, t) lam -> t =
+  fun env m ->
+  match env, m with
+  | _, Const n -> n
+  | Econs (_, v, r), Var _ -> v
+  | Econs (_, _, r), Shift e -> eval_lam r e
+  | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
+  | _, App (f, x)    -> eval_lam env f (eval_lam env x)
+;;
+
+type add = Add
+type suc = Suc
+
+let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil)))
+
+let _0 : (_, int) lam = Var Zero
+let suc x = App (Shift (Var Suc : (_, int -> int) lam), x)
+let _1 = suc _0
+let _2 = suc _1
+let _3 = suc _2
+let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
+
+let double = Abs (X, App (App (Shift add, Var X), Var X))
+let ex3 = App (double, _3)
+;;
+
+let v3 = eval_lam env0 ex3
+;;
+
+(* 5.13: Constructing typing derivations at runtime *)
+
+(* Modified slightly to use the language of 5.10, since this is more fun.
+   Of course this works also with the language of 5.12. *)
+
+type _ rep =
+  | I : int rep
+  | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+
+let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
+  fun a b ->
+  match a, b with
+  | I, I -> Inr Eq
+  | Ar(x,y), Ar(s,t) ->
+      begin match compare x s with
+      | Inl _ as e -> e
+      | Inr Eq -> match compare y t with
+        | Inl _ as e -> e
+        | Inr Eq as e -> e
+      end
+  | I, Ar _ -> Inl "I <> Ar _"
+  | Ar _, I -> Inl "Ar _ <> I"
+;;
+
+type term =
+  | C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+
+type _ ctx =
+  | Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx
+;;
+
+type _ checked =
+  | Cerror of string
+  | Cok : ('e,'t) lam * 't rep -> 'e checked
+
+let rec lookup : type e. string -> e ctx -> e checked =
+  fun name ctx ->
+  match ctx with
+  | Cnil -> Cerror ("Name not found: " ^ name)
+  | Ccons (l,s,t,rs) ->
+      if s = name then Cok (Var l,t) else
+      match lookup name rs with
+      | Cerror m -> Cerror m
+      | Cok (v, t) -> Cok (Shift v, t)
+;;
+
+let rec tc : type n e. n nat -> e ctx -> term -> e checked =
+  fun n ctx t ->
+  match t with
+  | V s -> lookup s ctx
+  | Ap(f,x) ->
+      begin match tc n ctx f with
+      | Cerror _ as e -> e
+      | Cok (f', ft) -> match tc n ctx x with
+        | Cerror _ as e -> e
+        | Cok (x', xt) ->
+            match ft with
+            | Ar (a, b) ->
+                begin match compare a xt with
+                | Inl s -> Cerror s
+                | Inr Eq -> Cok (App (f',x'), b)
+                end
+            | _ -> Cerror "Non fun in Ap"
+      end
+  | Ab(s,t,body) ->
+      begin match tc (NS n) (Ccons (n, s, t, ctx)) body with
+      | Cerror _ as e -> e
+      | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))
+      end
+  | C m -> Cok (Const m, I)
+;;
+
+let ctx0 =
+  Ccons (Zero, "0", I,
+         Ccons (Suc, "S", Ar(I,I),
+                Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil)))
+
+let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
+let c1 = tc NZ ctx0 ex1;;
+let ex2 = Ap (ex1, C 3);;
+let c2 = tc NZ ctx0 ex2;;
+
+let eval_checked env = function
+  | Cerror s -> failwith s
+  | Cok (e, I) -> (eval_lam env e : int)
+  | Cok _ -> failwith "Can only evaluate expressions of type I"
+;;
+
+let v2 = eval_checked env0 c2 ;;
+
+(* 5.12 Soundness *)
+
+type pexp
+type pval
+type _ mode =
+  | Pexp : pexp mode
+  | Pval : pval mode
+
+type (_,_) tarr
+type tint
+
+type (_,_) rel =
+  | IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+
+type (_,_,_) lam =
+  | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam
+  | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam
+  | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam
+  | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+;;
+
+let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+
+let rec mode : type m e t. (m,e,t) lam -> m mode = function
+  | Lam (v, body) -> Pval
+  | Var v -> Pval
+  | Const (r, v) -> Pval
+  | Shift e -> mode e
+  | App _ -> Pexp
+;;
+
+type (_,_) sub =
+  | Id : ('r,'r) sub
+  | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub
+  | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub
+
+type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam'
+;;
+
+let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
+  fun t s ->
+  match t, s with
+  | _, Id -> Ex t
+  | Const(r,c), sub -> Ex (Const (r,c))
+  | Var v, Bind (x, e, r) -> Ex e
+  | Var v, Push sub -> Ex (Var v)
+  | Shift e, Bind (_, _, r) -> subst e r
+  | Shift e, Push sub ->
+      (match subst e sub with Ex a -> Ex (Shift a))
+  | App(f,x), sub ->
+      (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y)))
+  | Lam(v,x), sub ->
+      (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
+;;
+
+type closed = rnil
+
+type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;;
+
+let rec rule : type a b.
+  (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam =
+  fun v1 v2 ->
+  match v1, v2 with
+  | Lam(x,body), v ->
+      begin
+        match subst body (Bind (x, v, Id)) with Ex term ->
+        match mode term with
+        | Pexp -> Inl term
+        | Pval -> Inr term
+      end
+  | Const (IntTo b, f), Const (IntR, x) ->
+      Inr (Const (b, f x))
+;;
+let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
+  | Lam (v, body) -> Inr (Lam (v, body))
+  | Const (r, v)  -> Inr (Const (r, v))
+  | App (e1, e2) ->
+      match mode e1, mode e2 with
+      | Pexp, _->
+          begin match onestep e1 with
+          | Inl e -> Inl(App(e,e2))
+          | Inr v -> Inl(App(v,e2))
+          end
+      | Pval, Pexp ->
+          begin match onestep e2 with
+          | Inl e -> Inl(App(e1,e))
+          | Inr v -> Inl(App(e1,v))
+          end
+      | Pval, Pval -> rule e1 e2
+;;
diff --git a/testsuite/tests/typing-gadts/omega07.ml.principal.reference b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
new file mode 100644
index 00000000..cf8b0b5b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
@@ -0,0 +1,306 @@
+
+# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type _ succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+#             type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+#       *         type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+#         val length : ('a, 'n) seq -> 'n 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 _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+#           type tt
+type ff
+type _ boolean = BT : tt boolean | BF : ff boolean
+#                 type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+#         type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  
+#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = 
+#             type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+#         type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+#       val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = 
+#                                 type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = 
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
+#             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 = 
+#               Characters 87-243:
+  ..match a, b,le with (* warning *)
+    | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+    | NS x, NS y, LeS q ->
+        match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(NS _, NZ, _)
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
+#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = 
+#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = 
+#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = 
+#                             type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+#                 val empty : avl' = Avl Leaf
+val elem : int -> 'h avl -> bool = 
+#                           val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = 
+#                         val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  
+#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = 
+#           val insert : int -> avl' -> avl' = 
+#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = 
+type _ avl_del =
+    Dsame : 'n avl -> 'n 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 (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+#               type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = 
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = 
+#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = 
+#             val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  
+#             val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  
+#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+#   val insert : int -> rb_tree -> rb_tree = 
+#                                                                                                 type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+val eval_term : 'a term -> 'a = 
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = 
+#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = 
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = 
+#           val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+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 _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (, Abs (, App (Shift (Var ), Var )))
+#                           type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = 
+#                               type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = 
+val _1 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), Var Zero)
+val _2 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (,
+   App (App (Shift (Shift (Shift (Var Add))), Var ), Var ))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+#     val v3 : int = 6
+#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = 
+#                     type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = 
+#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = 
+#             val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+# val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   Ar (I, I))
+# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+# val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (,
+       App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+     Const 3),
+   I)
+#           val eval_checked : 'a env -> 'a checked -> int = 
+#   val v2 : int = 6
+#                                             type pexp
+type pval
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type (_, _) tarr
+type tint
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+#                   val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (, Var ), Const (IntR, ))
+val mode : ('m, 'e, 't) lam -> 'm mode = 
+#               type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = 
+#       type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+#                             val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  
+#                                 val onestep : ('m, closed, 't) lam -> 't rlam = 
+# 
diff --git a/testsuite/tests/typing-gadts/omega07.ml.reference b/testsuite/tests/typing-gadts/omega07.ml.reference
new file mode 100644
index 00000000..cf8b0b5b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml.reference
@@ -0,0 +1,306 @@
+
+# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type _ succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+#             type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+#       *         type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+#         val length : ('a, 'n) seq -> 'n 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 _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+#           type tt
+type ff
+type _ boolean = BT : tt boolean | BF : ff boolean
+#                 type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+#         type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  
+#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = 
+#             type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+#         type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+#       val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = 
+#                                 type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = 
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
+#             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 = 
+#               Characters 87-243:
+  ..match a, b,le with (* warning *)
+    | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+    | NS x, NS y, LeS q ->
+        match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(NS _, NZ, _)
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
+#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = 
+#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = 
+#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = 
+#                             type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+#                 val empty : avl' = Avl Leaf
+val elem : int -> 'h avl -> bool = 
+#                           val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = 
+#                         val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  
+#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = 
+#           val insert : int -> avl' -> avl' = 
+#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = 
+type _ avl_del =
+    Dsame : 'n avl -> 'n 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 (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+#               type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = 
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = 
+#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = 
+#             val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  
+#             val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  
+#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+#   val insert : int -> rb_tree -> rb_tree = 
+#                                                                                                 type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+val eval_term : 'a term -> 'a = 
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = 
+#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = 
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = 
+#           val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+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 _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (, Abs (, App (Shift (Var ), Var )))
+#                           type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = 
+#                               type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = 
+val _1 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), Var Zero)
+val _2 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (,
+   App (App (Shift (Shift (Shift (Var Add))), Var ), Var ))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+#     val v3 : int = 6
+#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = 
+#                     type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = 
+#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = 
+#             val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+# val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   Ar (I, I))
+# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+# val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (,
+       App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+     Const 3),
+   I)
+#           val eval_checked : 'a env -> 'a checked -> int = 
+#   val v2 : int = 6
+#                                             type pexp
+type pval
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type (_, _) tarr
+type tint
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+#                   val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (, Var ), Const (IntR, ))
+val mode : ('m, 'e, 't) lam -> 'm mode = 
+#               type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = 
+#       type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+#                             val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  
+#                                 val onestep : ('m, closed, 't) lam -> 't rlam = 
+# 
diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
new file mode 100644
index 00000000..ef70e5a1
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -0,0 +1,17 @@
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+;;
+let x = f Tint (Tvar Zero)
+;;
diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
new file mode 100644
index 00000000..4cf48a22
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml.reference
@@ -0,0 +1,19 @@
+
+#       type ('env, 'a) var =
+    Zero : ('a * 'env, 'a) var
+  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+#         type ('env, 'a) typ =
+    Tint : ('env, int) typ
+  | Tbool : ('env, bool) typ
+  | Tvar : ('env, 'a) var -> ('env, 'a) typ
+#           Characters 72-156:
+  .match ta, tb with
+     | Tint, Tint -> 0
+     | Tbool, Tbool -> 1
+     | Tvar var, tb -> 2
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Tbool, Tvar _)
+val f : ('env, 'a) typ -> ('env, 'a) typ -> int = 
+#   Exception: Match_failure ("//toplevel//", 9, 1).
+# 
diff --git a/testsuite/tests/typing-gadts/term-conv.ml b/testsuite/tests/typing-gadts/term-conv.ml
new file mode 100644
index 00000000..9b53cd6e
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml
@@ -0,0 +1,139 @@
+(* HOAS to de Bruijn, by chak *)
+(* http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ *)
+
+module Typeable = struct
+  type 'a ty =
+    | Int: int ty
+    | String: string ty
+    | List: 'a ty -> 'a list ty
+    | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+    | Fun: ('a ty * 'b ty) -> ('a -> 'b) ty
+
+  type (_,_) eq = Eq : ('a,'a) eq
+
+  exception CastFailure
+  let rec check_eq : type t t'. t ty -> t' ty -> (t,t') eq = fun t t' ->
+    match t, t' with
+    | Int, Int -> Eq
+    | String, String -> Eq
+    | List t, List t' -> (match check_eq t t' with Eq -> Eq)
+    | Pair (t1,t2), Pair (t1',t2') ->
+        (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq)
+    | Fun (t1,t2), Fun (t1',t2') ->
+        (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq)
+    | _ -> raise CastFailure
+
+  let gcast : type t t'. t ty -> t' ty -> t -> t' = fun t t' x ->
+    match check_eq t t' with Eq -> x
+end;;
+
+module HOAS = struct
+  open Typeable
+
+  type _ term =
+    | Tag : 't ty * int -> 't term
+    | Con : 't -> 't term
+    | Lam : 's ty * ('s term -> 't term) -> ('s -> 't) term
+    | App : ('s -> 't) term * 's term -> 't term
+
+  let rec intp : type t. t term -> t = function
+    | Tag (_, ix) -> failwith "HOAS.intp"
+    | Con v      -> v
+    | Lam (_, f) -> fun x -> intp (f (Con x))
+    | App (f, a) -> intp f (intp a)
+end;;
+
+module DeBruijn = struct
+  type ('env,'t) ix =
+    | ZeroIx : ('env * 't, 't) ix
+    | SuccIx : ('env,'t) ix -> ('env * 's, 't) ix
+
+  let rec to_int : type env t. (env,t) ix -> int = function
+    | ZeroIx   -> 0
+    | SuccIx n -> to_int n + 1
+
+  type ('env,'t) term =
+    | Var : ('env,'t) ix -> ('env,'t) term
+    | Con : 't -> ('env,'t) term
+    | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+    | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+
+  type _ stack =
+    | Empty : unit stack
+    | Push : 'env stack * 't -> ('env * 't) stack
+
+  let rec prj : type env t. (env,t) ix -> env stack -> t = fun i s ->
+    match i, s with
+    | ZeroIx, Push (s,v) -> v
+    | SuccIx i, Push (s,_) -> prj i s
+
+  let rec intp : type env t. (env,t) term -> env stack -> t = fun t s ->
+    match t with
+    | Var ix -> prj ix s
+    | Con v  -> v
+    | Lam b  -> fun x -> intp b (Push (s, x))
+    | App(f,a) -> intp f s (intp a s)
+end;;
+
+module Convert = struct
+  type (_,_) layout =
+    | EmptyLayout : ('env, unit) layout
+    | PushLayout  :
+        't Typeable.ty * ('env,'env') layout * ('env,'t) DeBruijn.ix
+           -> ('env,'env' * 't) layout
+
+  let rec size : type env env'. (env,env') layout -> int = function
+    | EmptyLayout -> 0
+    | PushLayout (_, lyt, _) -> size lyt + 1
+
+  let rec inc : type env env'. (env,env') layout -> (env * 't, env') layout =
+    function
+      | EmptyLayout -> EmptyLayout
+      | PushLayout (t, lyt, ix) -> PushLayout (t, inc lyt, DeBruijn.SuccIx ix)
+
+  let rec prj : type env env' t.
+        t Typeable.ty -> int -> (env,env') layout -> (env,t) DeBruijn.ix
+    = fun t n -> function
+      | EmptyLayout -> failwith "Convert.prj: internal error"
+      | PushLayout (t', l, ix) ->
+          if n = 0 then
+            match Typeable.check_eq t t' with Typeable.Eq -> ix
+          else prj t (n-1) l
+
+  let rec cvt :
+    type env t. (env,env) layout -> t HOAS.term -> (env,t) DeBruijn.term =
+    fun lyt -> function
+      | HOAS.Tag (t, sz) -> DeBruijn.Var (prj t (size lyt - sz -1) lyt)
+      | HOAS.Con v -> DeBruijn.Con v
+      | HOAS.Lam (t, f) ->
+          let lyt' = PushLayout (t, inc lyt, DeBruijn.ZeroIx) in
+          DeBruijn.Lam (cvt lyt' (f (HOAS.Tag (t, size lyt))))
+      | HOAS.App (f, a) ->
+          DeBruijn.App (cvt lyt f, cvt lyt a)
+
+  let convert t = cvt EmptyLayout t
+end;;
+
+module Main = struct
+  open HOAS
+  let i t = Lam (t, fun x -> x)
+  let zero t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> x))
+  let one t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, x)))
+  let two t =
+    Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, App (f, x))))
+  let three t =
+    Lam (Typeable.Fun(t,t),
+         fun f -> Lam(t, fun x -> App (f, App (f, App (f, x)))))
+  let plus t =
+    let t1 = Typeable.Fun(t,t) in let t2 = Typeable.Fun(t1,t1) in
+    Lam (t2, fun m -> Lam (t2, fun n ->
+      Lam (t1, fun f -> Lam(t, fun x -> App(App(m,f), App(App(n,f),x))))))
+
+  let plus_2_3 t = App (App (plus t, two t), three t)
+
+  open Convert
+
+  let i' = convert (i Typeable.Int)
+  let plus_2_3' = convert (plus_2_3 Typeable.Int)
+  let eval_plus_2_3' = DeBruijn.intp plus_2_3' DeBruijn.Empty succ 0
+end;;
diff --git a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
new file mode 100644
index 00000000..cff10f16
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
@@ -0,0 +1,71 @@
+
+#                                                       module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+#                               module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+#                                                               module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+#                                                                             module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+#                                               module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+# 
diff --git a/testsuite/tests/typing-gadts/term-conv.ml.reference b/testsuite/tests/typing-gadts/term-conv.ml.reference
new file mode 100644
index 00000000..cff10f16
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml.reference
@@ -0,0 +1,71 @@
+
+#                                                       module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+#                               module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+#                                                               module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+#                                                                             module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+#                                               module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+# 
diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
new file mode 100644
index 00000000..3fb5730a
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -0,0 +1,514 @@
+module Exp = 
+  struct
+
+    type _ t = 
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t 
+
+
+    let rec eval : type s . s t -> s = 
+      function
+	| IntLit x -> x
+	| BoolLit y -> y
+	| Pair (x,y) ->
+            (eval x,eval y)
+	| App (f,a) ->
+	    (eval f) (eval a)
+	| Abs f -> f 
+
+    let discern : type a. a t -> _ = function
+        IntLit _ -> 1
+      | BoolLit _ -> 2
+      | Pair _ -> 3
+      | App _ -> 4
+      | Abs _ -> 5
+  end
+;;
+
+module List = 
+  struct
+    type zero
+    type _ t = 
+      | Nil : zero t
+      | Cons : 'a * 'b t -> ('a * 'b) t
+    let head =
+      function
+	| Cons (a,b) -> a
+    let tail =
+      function
+	| Cons (a,b) -> b
+    let rec length : type a . a t -> int = 
+      function
+	| Nil -> 0
+	| Cons (a,b) -> length b
+  end
+;;
+
+module Nonexhaustive = 
+  struct
+    type 'a u = 
+      | C1 : int -> int u 
+      | C2 : bool -> bool u
+	    
+    type 'a v = 
+      | C1 : int -> int v
+
+    let unexhaustive : type s . s u -> s = 
+      function
+	| C2 x -> x
+
+
+    module M : sig type t type u end = 
+      struct
+        type t = int
+        type u = bool
+      end	    
+    type 'a t = 
+      | Foo : M.t -> M.t t 
+      | Bar : M.u -> M.u t
+    let same_type : type s . s t * s t -> bool  =
+      function
+	| Foo _ , Foo _ -> true
+	| Bar _, Bar _ -> true
+  end
+;;
+
+module Exhaustive = 
+  struct
+    type t = int
+    type u = bool
+    type 'a v = 
+      | Foo : t -> t v 
+      | Bar : u -> u v
+
+    let same_type : type s . s v * s v -> bool  =
+      function
+	| Foo _ , Foo _ -> true
+	| Bar _, Bar _ -> true    
+  end
+;;
+
+module Existential_escape = 
+  struct
+    type _ t = C : int -> int t
+    type u = D : 'a t -> u
+    let eval (D x) = x
+  end
+;;
+
+module Rectype = 
+  struct
+    type (_,_) t = C : ('a,'a) t 
+    let _ = 
+      fun (type s) ->
+	let a : (s, s * s) t = failwith "foo" in 
+	match a with
+	  C ->
+	    ()
+  end
+;;
+
+module Or_patterns = 
+struct
+      type _ t = 
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+
+    let rec eval : type s . s t -> unit = 
+      function
+	| (IntLit _ | BoolLit _) -> ()
+
+end
+;;
+
+module Polymorphic_variants = 
+  struct
+      type _ t = 
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+
+    let rec eval : type s . [`A] * s t -> unit = 
+      function
+	| `A, IntLit _ -> ()
+	| `A, BoolLit _ -> ()
+  end    
+;;
+
+module Propagation = struct
+  type _ t = 
+      IntLit : int -> int t
+    | BoolLit : bool -> bool t
+
+  let check : type s. s t -> s = function
+    | IntLit n -> n
+    | BoolLit b -> b
+
+  let check : type s. s t -> s = fun x ->
+    let r = match x with
+    | IntLit n -> (n : s )
+    | BoolLit b -> b
+    in r
+end
+;;
+
+module Normal_constrs = struct
+  type a = A
+  type b = B
+
+  let f = function A -> 1 | B -> 2
+end;;
+
+type _ t = Int : int t ;;
+
+let ky x y = ignore (x = y); x ;;
+
+let test : type a. a t -> a =
+  function Int -> ky (1 : a) 1
+;;
+
+let test : type a. a t -> _ =
+  function Int -> 1       (* ok *)
+;;
+
+let test : type a. a t -> _ =
+  function Int -> ky (1 : a) 1  (* fails *)
+;;
+
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> ky (1 : a) 1  (* fails *)
+  in r
+;;
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+  in r
+;;
+let test (type a) x =
+  let r = match (x : a t) with Int -> ky 1 1
+  in r
+;;
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> (1 : a)       (* ok! *)
+  in r
+;;
+let test : type a. a t -> _ = fun x ->
+  let r = match x with Int -> 1       (* ok! *)
+  in r
+;;
+let test : type a. a t -> a = fun x ->
+  let r : a = match x with Int -> 1
+  in r (* ok *)
+;;
+let test2 : type a. a t -> a option = fun x ->
+  let r = ref None in
+  begin match x with Int -> r := Some (1 : a) end;
+  !r (* ok *)
+;;
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  begin match x with Int -> r := Some 1 end;
+  !r (* ok *)
+;;
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  let u = ref None in
+  begin match x with Int -> r := Some 1; u := !r end;
+  !u
+;; (* ok (u non-ambiguous) *)
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  let u = ref None in
+  begin match x with Int -> u := Some 1; r := !u end;
+  !u
+;; (* fails because u : (int | a) option ref *)
+let test2 : type a. a t -> a option = fun x ->
+  let u = ref None in
+  let r : a option ref = ref None in
+  begin match x with Int -> r := Some 1; u := !r end;
+  !u
+;; (* ok *)
+let test2 : type a. a t -> a option = fun x ->
+  let u = ref None in
+  let a =
+    let r : a option ref = ref None in
+    begin match x with Int -> r := Some 1; u := !r end;
+    !u
+  in a
+;; (* ok *)
+let either = ky
+let we_y1x (type a) (x : a) (v : a t) =
+  match v with Int -> let y = either 1 x in y
+;; (* fail *)
+
+(* Effect of external consraints *)
+let f (type a) (x : a t) y =
+  ignore (y : a);
+  let r = match x with Int -> (y : a) in (* ok *)
+  r
+;;
+let f (type a) (x : a t) y =
+  let r = match x with Int -> (y : a) in
+  ignore (y : a); (* ok *)
+  r
+;;
+let f (type a) (x : a t) y =
+  ignore (y : a);
+  let r = match x with Int -> y in (* ok *)
+  r
+;;
+let f (type a) (x : a t) y =
+  let r = match x with Int -> y in
+  ignore (y : a); (* ok *)
+  r
+;;
+let f (type a) (x : a t) (y : a) =
+  match x with Int -> y (* returns 'a *)
+;;
+
+(* Combination with local modules *)
+
+let f (type a) (x : a t) y =
+  match x with Int ->
+    let module M = struct type b = a let z = (y : b) end
+    in M.z
+;; (* fails because of aliasing... *)
+
+let f (type a) (x : a t) y =
+  match x with Int ->
+    let module M = struct type b = int let z = (y : b) end
+    in M.z
+;; (* ok *)
+
+(* Objects and variants *)
+
+type _ h =
+  | Has_m :  h
+  | Has_b :  h
+
+let f : type a. a h -> a = function
+  | Has_m -> object method m = 1 end
+  | Has_b -> object method b = true end
+;;
+type _ j =
+  | Has_A : [`A of int] j
+  | Has_B : [`B of bool] j
+
+let f : type a. a j -> a = function
+  | Has_A -> `A 1
+  | Has_B -> `B true
+;;
+
+type (_,_) eq = Eq : ('a,'a) eq ;;
+
+let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
+  fun Eq o -> o
+;; (* fail *)
+
+let f : type a b. (a,b) eq ->  ->  =
+  fun Eq o -> o
+;; (* fail *)
+
+let f (type a) (type b) (eq : (a,b) eq) (o : ) :  =
+  match eq with Eq -> o ;; (* should fail *)
+
+let f : type a b. (a,b) eq ->  ->  =
+  fun Eq o -> o
+;; (* ok *)
+
+let int_of_bool : (bool,int) eq = Obj.magic Eq;;
+
+let x = object method m = true end;;
+let y = (x, f int_of_bool x);;
+
+let f : type a. (a, int) eq ->  -> bool =
+  fun Eq o -> ignore (o : ); o#m = 3
+;; (* should be ok *)
+
+let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
+  fun eq o ->
+    ignore (o : < m : a >);
+    let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
+    r;;
+
+let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
+  fun eq o ->
+    let r : < m : b > = match eq with Eq -> o in (* fail *)
+    ignore (o : < m : a >);
+    r;;
+
+let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] =
+  fun Eq o -> o ;; (* fail *)
+
+let f (type a) (type b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] =
+  match eq with Eq -> v ;; (* should fail *)
+
+let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+  fun Eq o -> o ;; (* fail *)
+
+let f : type a b. (a,b) eq -> [`A of a | `B] -> [`A of b | `B] =
+  fun Eq o -> o ;; (* ok *)
+
+let f : type a. (a, int) eq -> [`A of a] -> bool =
+  fun Eq v -> match v with `A 1 -> true | _ -> false
+;; (* ok *)
+
+let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
+  fun eq o ->
+    ignore (o : [< `A of a | `B]);
+    let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
+    r;;
+
+let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
+  fun eq o ->
+    let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+    ignore (o : [< `A of a | `B]);
+    r;;
+
+(* Pattern matching *)
+
+type 'a t =
+    A of int | B of bool | C of float | D of 'a
+
+type _ ty =
+  | TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match x, y with
+  | _, A z -> z
+  | _, B z -> if z then 1 else 2
+  | _, C z -> truncate z
+  | TE TC, D [|1.0|] -> 14
+  | TA, D 0 -> -1
+  | TA, D z -> z
+  | TD "bye", D false -> 13
+  | TD "hello", D true -> 12
+ (* | TB, D z -> if z then 1 else 2 *)
+  | TC, D z -> truncate z
+  | _, D _ -> 0
+;;
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match x, y with
+  | _, A z -> z
+  | _, B z -> if z then 1 else 2
+  | _, C z -> truncate z
+  | TE TC, D [|1.0|] -> 14
+  | TA, D 0 -> -1
+  | TA, D z -> z
+;; (* warn *)
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match y, x with
+  | A z, _ -> z
+  | B z, _ -> if z then 1 else 2
+  | C z, _ -> truncate z
+  | D [|1.0|], TE TC -> 14
+  | D 0, TA -> -1
+  | D z, TA -> z
+;; (* fail *)
+
+type ('a,'b) pair = {right:'a; left:'b}
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match {left=x; right=y} with
+  | {left=_; right=A z} -> z
+  | {left=_; right=B z} -> if z then 1 else 2
+  | {left=_; right=C z} -> truncate z
+  | {left=TE TC; right=D [|1.0|]} -> 14
+  | {left=TA; right=D 0} -> -1
+  | {left=TA; right=D z} -> z
+;; (* fail *)
+
+type ('a,'b) pair = {left:'a; right:'b}
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match {left=x; right=y} with
+  | {left=_; right=A z} -> z
+  | {left=_; right=B z} -> if z then 1 else 2
+  | {left=_; right=C z} -> truncate z
+  | {left=TE TC; right=D [|1.0|]} -> 14
+  | {left=TA; right=D 0} -> -1
+  | {left=TA; right=D z} -> z
+;; (* ok *)
+
+(* Injectivity *)
+
+module M : sig type 'a t val eq : ('a t, 'b t) eq end =
+  struct type 'a t = int let eq = Eq end
+;;
+
+let f : type a b. (a M.t, b M.t) eq -> (a, b) eq =
+  function Eq -> Eq (* fail *)
+;;
+
+let f : type a b. (a M.t * a, b M.t * b) eq -> (a, b) eq =
+  function Eq -> Eq (* ok *)
+;;
+
+let f : type a b. (a * a M.t, b * b M.t) eq -> (a, b) eq =
+  function Eq -> Eq (* ok *)
+;;
+
+(* Applications of polymorphic variants *)
+
+type _ t =
+  | V1 : [`A | `B] t
+  | V2 : [`C | `D] t
+
+let f : type a. a t -> a = function
+  | V1 -> `A
+  | V2 -> `C
+;;
+
+f V1;;
+
+(* PR#5425 and PR#5427 *)
+
+type _ int_foo =
+  | IF_constr :  int_foo
+
+type _ int_bar = 
+  | IB_constr :  int_bar
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t =
+  let IF_constr, IB_constr = e, e' in
+  (x:)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  x, x#foo, x#bar
+;;
+
+(* PR#5554 *)
+
+type 'a ty = Int : int -> int ty;;
+
+let f : type a. a ty -> a =
+  fun x -> match x with Int y -> y;;
+
+let g : type a. a ty -> a =
+  let () = () in
+  fun x -> match x with Int y -> y;;
diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
new file mode 100644
index 00000000..3125e1e6
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml.principal.reference
@@ -0,0 +1,309 @@
+
+#                                                         module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+#                                     module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+#                                                         Characters 206-227:
+  ......function
+  	| C2 x -> x
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+C1 _
+Characters 469-526:
+  ......function
+  	| Foo _ , Foo _ -> true
+  	| Bar _, Bar _ -> true
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+#                             module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+#               Characters 119-120:
+      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
+#                       Characters 157-158:
+  	  C ->
+     ^
+Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t
+#                         Characters 174-182:
+  	| (IntLit _ | BoolLit _) -> ()
+      ^^^^^^^^
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+#                         Characters 213-226:
+  	| `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
+#                                 Characters 300-301:
+      | BoolLit b -> b
+                     ^
+Error: This expression has type bool but an expression was expected of type s
+#             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
+#   type _ t = Int : int t
+#   val ky : 'a -> 'a -> 'a = 
+#       val test : 'a t -> 'a = 
+#       val test : 'a t -> int = 
+#       Characters 49-61:
+    function Int -> ky (1 : a) 1  (* fails *)
+                    ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#         Characters 70-82:
+    let r = match x with Int -> ky (1 : a) 1  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       Characters 69-81:
+    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       val test : 'a t -> int = 
+#       val test : 'a t -> 'a = 
+#       val test : 'a t -> int = 
+#       val test : 'a t -> 'a = 
+#         val test2 : 'a t -> 'a option = 
+#         val test2 : 'a t -> 'a option = 
+#           val test2 : 'a t -> 'a option = 
+#           Characters 152-154:
+    begin match x with Int -> u := Some 1; r := !u end;
+                                                ^^
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int 
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val test2 : 'a t -> 'a option = 
+#               val test2 : 'a t -> 'a option = 
+#       Characters 100-101:
+    match v with Int -> let y = either 1 x in y
+                                              ^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#             val f : 'a t -> 'a -> 'a = 
+#         val f : 'a t -> 'a -> 'a = 
+#         val f : 'a t -> 'a -> 'a = 
+#         val f : 'a t -> 'a -> 'a = 
+#     val f : 'a t -> 'a -> 'a = 
+#               Characters 136-137:
+      let module M = struct type b = a let z = (y : b) end
+                                                ^
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val f : 'a t -> int -> int = 
+#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = 
+#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = 
+#   type (_, _) eq = Eq : ('a, 'a) eq
+#       Characters 5-91:
+  ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
+    fun Eq o -> o
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+#       Characters 74-75:
+    fun Eq o -> o
+                ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> o ;; (* should fail *)
+                        ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+#   val int_of_bool : (bool, int) eq = Eq
+#   val x : < m : bool > = 
+# val y : < m : bool > * < m : int > = (, )
+#       val f : ('a, int) eq -> < m : 'a > -> bool = 
+#           Characters 146-147:
+      let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
+                                              ^
+Error: This expression has type < m : a >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#           Characters 118-119:
+      let r : < m : b > = match eq with Eq -> o in (* fail *)
+                                              ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 74-75:
+    fun Eq o -> o ;; (* fail *)
+                ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> v ;; (* should fail *)
+                        ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 5-85:
+  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+    fun Eq o -> o..............
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = 
+#           Characters 166-167:
+      let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
+                                                   ^
+Error: This expression has type [ `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#           Characters 131-132:
+      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+                                                   ^
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = 
+#                   Characters 51-202:
+  ..match x, y with
+    | _, A z -> z
+    | _, B z -> if z then 1 else 2
+    | _, C z -> truncate z
+    | TE TC, D [|1.0|] -> 14
+    | TA, D 0 -> -1
+    | TA, D z -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(TE TC, D [|  |])
+val f : 'a ty -> 'a t -> int = 
+#                   Characters 147-154:
+    | D [|1.0|], TE TC -> 14
+        ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 259-266:
+    | {left=TE TC; right=D [|1.0|]} -> 14
+                           ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 92-334:
+  ..match {left=x; right=y} with
+    | {left=_; right=A z} -> z
+    | {left=_; right=B z} -> if z then 1 else 2
+    | {left=_; right=C z} -> truncate z
+    | {left=TE TC; right=D [|1.0|]} -> 14
+    | {left=TA; right=D 0} -> -1
+    | {left=TA; right=D z} -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{left=TE TC; right=D [|  |]}
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+val f : 'a ty -> 'a t -> int = 
+#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
+#       Characters 69-71:
+    function Eq -> Eq (* fail *)
+                   ^^
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+#       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
+val f : 'a t -> 'a = 
+#   - : [ `A | `B ] = `A
+#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+#         Characters 98-99:
+    (x:)
+     ^
+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 <  > 
+       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
+         < bar : int > 
+#         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
+#         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 = 
+# 
diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference
new file mode 100644
index 00000000..36401d16
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml.reference
@@ -0,0 +1,296 @@
+
+#                                                         module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+#                                     module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+#                                                         Characters 206-227:
+  ......function
+  	| C2 x -> x
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+C1 _
+Characters 469-526:
+  ......function
+  	| Foo _ , Foo _ -> true
+  	| Bar _, Bar _ -> true
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+#                             module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+#               Characters 119-120:
+      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
+#                       Characters 157-158:
+  	  C ->
+     ^
+Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t
+#                         Characters 174-182:
+  	| (IntLit _ | BoolLit _) -> ()
+      ^^^^^^^^
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+#                         Characters 213-226:
+  	| `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
+#                                 module Propagation :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val check : 's t -> 's
+  end
+#             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
+#   type _ t = Int : int t
+#   val ky : 'a -> 'a -> 'a = 
+#       val test : 'a t -> 'a = 
+#       val test : 'a t -> int = 
+#       Characters 49-61:
+    function Int -> ky (1 : a) 1  (* fails *)
+                    ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#         Characters 70-82:
+    let r = match x with Int -> ky (1 : a) 1  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       Characters 69-81:
+    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       val test : 'a t -> int = 
+#       val test : 'a t -> 'a = 
+#       val test : 'a t -> int = 
+#       val test : 'a t -> 'a = 
+#         val test2 : 'a t -> 'a option = 
+#         val test2 : 'a t -> 'a option = 
+#           val test2 : 'a t -> 'a option = 
+#           Characters 152-154:
+    begin match x with Int -> u := Some 1; r := !u end;
+                                                ^^
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int 
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val test2 : 'a t -> 'a option = 
+#               val test2 : 'a t -> 'a option = 
+#       Characters 100-101:
+    match v with Int -> let y = either 1 x in y
+                                              ^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#             val f : 'a t -> 'a -> 'a = 
+#         val f : 'a t -> 'a -> 'a = 
+#         val f : 'a t -> 'a -> 'a = 
+#         val f : 'a t -> 'a -> 'a = 
+#     val f : 'a t -> 'a -> 'a = 
+#               Characters 136-137:
+      let module M = struct type b = a let z = (y : b) end
+                                                ^
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val f : 'a t -> int -> int = 
+#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = 
+#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = 
+#   type (_, _) eq = Eq : ('a, 'a) eq
+#       Characters 5-91:
+  ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
+    fun Eq o -> o
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+#       Characters 74-75:
+    fun Eq o -> o
+                ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> o ;; (* should fail *)
+                        ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+#   val int_of_bool : (bool, int) eq = Eq
+#   val x : < m : bool > = 
+# val y : < m : bool > * < m : int > = (, )
+#       val f : ('a, int) eq -> < m : 'a > -> bool = 
+#           val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+#           Characters 118-119:
+      let r : < m : b > = match eq with Eq -> o in (* fail *)
+                                              ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 74-75:
+    fun Eq o -> o ;; (* fail *)
+                ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> v ;; (* should fail *)
+                        ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 5-85:
+  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+    fun Eq o -> o..............
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = 
+#           val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+#           Characters 131-132:
+      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+                                                   ^
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = 
+#                   Characters 51-202:
+  ..match x, y with
+    | _, A z -> z
+    | _, B z -> if z then 1 else 2
+    | _, C z -> truncate z
+    | TE TC, D [|1.0|] -> 14
+    | TA, D 0 -> -1
+    | TA, D z -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(TE TC, D [|  |])
+val f : 'a ty -> 'a t -> int = 
+#                   Characters 147-154:
+    | D [|1.0|], TE TC -> 14
+        ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 259-266:
+    | {left=TE TC; right=D [|1.0|]} -> 14
+                           ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 92-334:
+  ..match {left=x; right=y} with
+    | {left=_; right=A z} -> z
+    | {left=_; right=B z} -> if z then 1 else 2
+    | {left=_; right=C z} -> truncate z
+    | {left=TE TC; right=D [|1.0|]} -> 14
+    | {left=TA; right=D 0} -> -1
+    | {left=TA; right=D z} -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{left=TE TC; right=D [|  |]}
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+val f : 'a ty -> 'a t -> int = 
+#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
+#       Characters 69-71:
+    function Eq -> Eq (* fail *)
+                   ^^
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+#       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
+val f : 'a t -> 'a = 
+#   - : [ `A | `B ] = `A
+#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+#         Characters 98-99:
+    (x:)
+     ^
+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 <  > 
+       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
+         < bar : int > 
+#         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
+#         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 = 
+# 
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml
new file mode 100644
index 00000000..08708a67
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml
@@ -0,0 +1,45 @@
+(* Injectivity *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let module M =
+      (functor (T : sig type 'a t end) ->
+       struct
+         let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+       end)
+        (struct type 'a t = unit end)
+    in M.f Refl
+;;
+
+(* Variance and subtyping *)
+
+type (_, +_) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let bad_proof (type a) =
+      (Refl : (< m : a>, ) eq :> (, < >) eq) in
+    let downcast : type a. (a, < >) eq -> < > -> a =
+      fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
+    (downcast bad_proof ((object method m = x end) :> < >)) # m
+;;
+
+(* Record patterns *)
+
+type _ t =
+  | IntLit : int t
+  | BoolLit : bool t
+
+let check : type s . s t * s -> bool = function
+  | BoolLit, false -> false
+  | IntLit , 6 -> false
+;;
+
+type ('a, 'b) pair = { fst : 'a; snd : 'b }
+
+let check : type s . (s t, s) pair -> bool = function
+  | {fst = BoolLit; snd = false} -> false
+  | {fst = IntLit ; snd =  6} -> false
+;;
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
new file mode 100644
index 00000000..ddae4d24
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
@@ -0,0 +1,29 @@
+
+#                           Characters 240-248:
+           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+                                              ^^^^^^^^
+Error: Type a is not a subtype of b 
+#                         Characters 36-67:
+  type (_, +_) eq = Refl : ('a, 'a) eq
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+#                     Characters 115-175:
+  .......................................function
+    | BoolLit, false -> false
+    | IntLit , 6 -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(IntLit, 0)
+type _ t = IntLit : int t | BoolLit : bool t
+val check : 's t * 's -> bool = 
+#             Characters 91-180:
+  .............................................function
+    | {fst = BoolLit; snd = false} -> false
+    | {fst = IntLit ; snd =  6} -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{fst=IntLit; snd=0}
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+val check : ('s t, 's) pair -> bool = 
+# 
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
new file mode 100644
index 00000000..ddae4d24
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
@@ -0,0 +1,29 @@
+
+#                           Characters 240-248:
+           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+                                              ^^^^^^^^
+Error: Type a is not a subtype of b 
+#                         Characters 36-67:
+  type (_, +_) eq = Refl : ('a, 'a) eq
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+#                     Characters 115-175:
+  .......................................function
+    | BoolLit, false -> false
+    | IntLit , 6 -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(IntLit, 0)
+type _ t = IntLit : int t | BoolLit : bool t
+val check : 's t * 's -> bool = 
+#             Characters 91-180:
+  .............................................function
+    | {fst = BoolLit; snd = false} -> false
+    | {fst = IntLit ; snd =  6} -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{fst=IntLit; snd=0}
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+val check : ('s t, 's) pair -> bool = 
+# 
diff --git a/testsuite/tests/typing-implicit_unpack/Makefile b/testsuite/tests/typing-implicit_unpack/Makefile
new file mode 100644
index 00000000..5f42b705
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+
diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
new file mode 100644
index 00000000..3910059f
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
@@ -0,0 +1,165 @@
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module 
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;
diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
new file mode 100644
index 00000000..32c49a29
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
@@ -0,0 +1,166 @@
+
+# * * * * * * * * *                               val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = 
+val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = 
+val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = 
+module type S = sig type t val x : t end
+# val f : (module S with type t = int) -> int = 
+# Characters 6-37:
+  let f (module M : S with type t = 'a) = M.x;; (* Error *)
+        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+# val f : (module S with type t = 'a) -> 'a = 
+# - : int = 1
+#   type 'a s = { s : (module S with type t = 'a); }
+# - : int s = {s = }
+# Characters 9-19:
+  let f {s=(module M)} = M.x;; (* Error *)
+           ^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+# val f : 'a s -> 'a = 
+#   type s = { s : (module S with type t = int); }
+# val f : s -> int = 
+# val f : s -> s -> int = 
+#   module type S = sig val x : int end
+# val f : (module S) -> int -> (module S) -> int = 
+# Characters 8-37:
+  let m = (module struct let x = 3 end);; (* Error *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The signature for this packaged module couldn't be inferred.
+# val m : (module S) = 
+# - : int = 7
+# - : int = 6
+#   - : int = 3
+# Characters 4-14:
+  let (module M) = m;; (* Error: only allowed in [let .. in] *)
+      ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+# Characters 14-24:
+  class c = let (module M) = m in object end;; (* Error again *)
+                ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+# module M : S
+#   module type S' = sig val f : int -> int end
+#       - : int = 6
+#                                                                                                                                                                                   module type S = sig type t type u val x : t * u end
+val f :
+  (module S with type t = int and type u = bool) list ->
+  (module S with type u = bool) list = 
+module TypEq :
+  sig
+    type ('a, 'b) t
+    val apply : ('a, 'b) t -> 'a -> 'b
+    val refl : ('a, 'a) t
+    val sym : ('a, 'b) t -> ('b, 'a) t
+  end
+module rec Typ :
+  sig
+    module type PAIR =
+      sig
+        type t
+        and t1
+        and t2
+        val eq : (t, t1 * t2) TypEq.t
+        val t1 : t1 Typ.typ
+        val t2 : t2 Typ.typ
+      end
+    type 'a typ =
+        Int of ('a, int) TypEq.t
+      | String of ('a, string) TypEq.t
+      | Pair of (module PAIR with type t = 'a)
+  end
+val int : int Typ.typ = Int 
+val str : string Typ.typ = String 
+val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = 
+val to_string : 'a Typ.typ -> 'a -> string = 
+module type MapT =
+  sig
+    type key
+    type +'a 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 -> int) -> 'a t -> 'a t -> int
+    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 -> int
+    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
+    type data
+    type map
+    val of_t : data t -> map
+    val to_t : map -> data t
+  end
+type ('k, 'd, 'm) map =
+    (module MapT with type data = 'd and type key = 'k and type map = 'm)
+val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = 
+module SSMap :
+  sig
+    type key = String.t
+    type 'a t = 'a Map.Make(String).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 -> int) -> 'a t -> 'a t -> int
+    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 -> int
+    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
+    type data = string
+    type map = data t
+    val of_t : 'a -> 'a
+    val to_t : 'a -> 'a
+  end
+val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  
+#         val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  
+#           val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  
+#       val ssmap :
+  (module MapT with type data = SSMap.data and type key = SSMap.key and type map = 
+   SSMap.map) =
+  
+#   val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = 
+#   - : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = 
+# 
diff --git a/testsuite/tests/typing-labels/.svnignore b/testsuite/tests/typing-labels/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/typing-labels/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < 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/Test.ml b/testsuite/tests/typing-modules/Test.ml
index 82ea468f..77c9d097 100644
--- a/testsuite/tests/typing-modules/Test.ml
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -3,3 +3,9 @@ module type S' = S with type t := int;;
 
 module type S = sig module rec M : sig end and N : sig end end;;
 module type S' = S with module M := String;;
+
+(* A subtle problem appearing with -principal *)
+type -'a t
+class type c = object method m : [ `A ] t end;;
+module M : sig val v : (#c as 'a) -> 'a end =
+  struct let v x = ignore (x :> c); x end;;
diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference
new file mode 100644
index 00000000..258b3ee3
--- /dev/null
+++ b/testsuite/tests/typing-modules/Test.ml.principal.reference
@@ -0,0 +1,9 @@
+
+# module type S = sig type t and s = t end
+# module type S' = sig type s = int end
+#   module type S = sig module rec M : sig  end and N : sig  end end
+# module type S' = sig module rec N : sig  end end
+#       type -'a t
+class type c = object method m : [ `A ] t end
+#   module M : sig val v : (#c as 'a) -> 'a end
+# 
diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference
index 823cc1a8..258b3ee3 100644
--- a/testsuite/tests/typing-modules/Test.ml.reference
+++ b/testsuite/tests/typing-modules/Test.ml.reference
@@ -3,4 +3,7 @@
 # module type S' = sig type s = int end
 #   module type S = sig module rec M : sig  end and N : sig  end end
 # module type S' = sig module rec N : sig  end end
+#       type -'a t
+class type c = object method m : [ `A ] t end
+#   module M : sig val v : (#c as 'a) -> 'a end
 # 
diff --git a/testsuite/tests/typing-objects-bugs/Makefile b/testsuite/tests/typing-objects-bugs/Makefile
index 9375ddba..1b07f206 100644
--- a/testsuite/tests/typing-objects-bugs/Makefile
+++ b/testsuite/tests/typing-objects-bugs/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects/.svnignore b/testsuite/tests/typing-objects/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/typing-objects/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < int_comparable);;
-(new sorted_list ())#add c3;;   (* Echec : leq n'est pas binaire *)
+(new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
 
 let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;;
 let pr l =
diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
new file mode 100644
index 00000000..d6f9d6df
--- /dev/null
+++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
@@ -0,0 +1,358 @@
+
+#           class point :
+  int ->
+  object val mutable x : int method get_x : int method move : int -> unit end
+#   val p : point = 
+#   - : int = 7
+# - : unit = ()
+# - : int = 10
+#   val q : < get_x : int; move : int -> unit > = 
+#   - : int * int = (10, 17)
+#           class color_point :
+  int ->
+  string ->
+  object
+    val c : string
+    val mutable x : int
+    method color : string
+    method get_x : int
+    method move : int -> unit
+  end
+#   val p' : color_point = 
+#   - : int * string = (5, "red")
+#   val l : point list = [; ]
+#   val get_x : < get_x : 'a; .. > -> 'a = 
+# val set_x : < set_x : 'a; .. > -> 'a = 
+# - : int list = [10; 5]
+#           Characters 7-96:
+  ......ref x_init = object
+    val mutable x = x_init
+    method get = x
+    method set y = x <- y
+  end..
+Error: Some type variables are unbound in this type:
+         class ref :
+           'a ->
+           object
+             val mutable x : 'a
+             method get : 'a
+             method set : 'a -> unit
+           end
+       The method get has type 'a where 'a is unbound
+#           class ref :
+  int ->
+  object val mutable x : int method get : int method set : int -> unit end
+#           class ['a] ref :
+  'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
+#   - : int = 2
+#             class ['a] circle :
+  'a ->
+  object
+    constraint 'a = < move : int -> unit; .. >
+    val mutable center : 'a
+    method center : 'a
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#               class ['a] circle :
+  'a ->
+  object
+    constraint 'a = #point
+    val mutable center : 'a
+    method center : 'a
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#   val c : point circle = 
+val c' : < color : string; get_x : int; move : int -> unit > circle = 
+#           class ['a] color_circle :
+  'a ->
+  object
+    constraint 'a = #color_point
+    val mutable center : 'a
+    method center : 'a
+    method color : string
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#   Characters 28-29:
+  let c'' = new color_circle p;;
+                             ^
+Error: This expression has type point but an expression was expected of type
+         #color_point
+       The first object type has no method color
+# val c'' : color_point color_circle = 
+#   - : color_point circle = 
+# Characters 0-21:
+  (c'' :> point circle);;                 (* Echec *)
+  ^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       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 
+# Characters 9-55:
+  fun x -> (x : color_point color_circle :> point circle);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       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 
+#         class printable_point :
+  int ->
+  object
+    val mutable x : int
+    method get_x : int
+    method move : int -> unit
+    method print : unit
+  end
+#   val p : printable_point = 
+# 7- : unit = ()
+#                     Characters 85-102:
+    inherit printable_point y as super
+            ^^^^^^^^^^^^^^^^^
+Warning 13: the following instance variables are overridden by the class printable_point :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class printable_color_point :
+  int ->
+  string ->
+  object
+    val c : string
+    val mutable x : int
+    method color : string
+    method get_x : int
+    method move : int -> unit
+    method print : unit
+  end
+#   val p' : printable_color_point = 
+# (7, red)- : unit = ()
+#           class functional_point :
+  int ->
+  object ('a) val x : int method get_x : int method move : int -> 'a end
+#   val p : functional_point = 
+#   - : int = 7
+# - : int = 10
+# - : int = 7
+#   - : #functional_point -> functional_point = 
+#                                                                       class virtual ['a] lst :
+  unit ->
+  object
+    method virtual hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method virtual null : bool
+    method print : ('a -> unit) -> unit
+    method virtual tl : 'a lst
+  end
+and ['a] nil :
+  unit ->
+  object
+    method hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method null : bool
+    method print : ('a -> unit) -> unit
+    method tl : 'a lst
+  end
+and ['a] cons :
+  'a ->
+  'a lst ->
+  object
+    val h : 'a
+    val t : 'a lst
+    method hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method null : bool
+    method print : ('a -> unit) -> unit
+    method tl : 'a lst
+  end
+#   val l1 : int lst = 
+#   (3::10::[])- : unit = ()
+#   val l2 : int lst = 
+# (4::11::[])- : unit = ()
+#       val map_list : ('a -> 'b) -> 'a lst -> 'b lst = 
+#   val p1 : printable_color_point lst = 
+# ((3, red)::(10, red)::[])- : unit = ()
+#           class virtual comparable :
+  unit -> object ('a) method virtual leq : 'a -> bool end
+#             class int_comparable :
+  int -> object ('a) val x : int method leq : 'a -> bool method x : int end
+#           class int_comparable2 :
+  int ->
+  object ('a)
+    val x : int
+    val mutable x' : int
+    method leq : 'a -> bool
+    method set_x : int -> unit
+    method x : int
+  end
+#                         class ['a] sorted_list :
+  unit ->
+  object
+    constraint 'a = #comparable
+    val mutable l : 'a list
+    method add : 'a -> unit
+    method hd : 'a
+  end
+#   val l : _#comparable sorted_list = 
+# val c : int_comparable = 
+# - : unit = ()
+#   val c2 : int_comparable2 = 
+# Characters 6-28:
+  l#add (c2 :> int_comparable);;      (* Echec : 'a comp2 n'est un sous-type *)
+        ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         int_comparable2 =
+           < 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 > 
+# - : unit = ()
+#             class int_comparable3 :
+  int ->
+  object
+    val mutable x : int
+    method leq : int_comparable -> bool
+    method setx : int -> unit
+    method x : int
+  end
+#   val c3 : int_comparable3 = 
+# - : unit = ()
+# Characters 25-27:
+  (new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
+                           ^^
+Error: This expression has type
+         int_comparable3 =
+           < leq : int_comparable -> bool; setx : int -> unit; x : int >
+       but an expression was expected of type
+         #comparable as 'a = < leq : 'a -> bool; .. >
+       Type int_comparable = < leq : int_comparable -> bool; x : int >
+       is not compatible with type 'a = < leq : 'a -> bool; .. > 
+       The first object type has no method setx
+#   val sort : (#comparable as 'a) list -> 'a list = 
+#     Characters 13-66:
+    List.map (fun c -> print_int c#x; print_string " ") l;
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 10: this expression should have type unit.
+val pr : < x : int; .. > list -> unit = 
+#   val l : int_comparable list = [; ; ]
+# 5 2 4 
+- : unit = ()
+# 2 4 5 
+- : unit = ()
+# val l : int_comparable2 list = [; ]
+# 2 0 
+- : unit = ()
+# 0 2 
+- : unit = ()
+#     val min : (#comparable as 'a) -> 'a -> 'a = 
+#   - : int = 7
+# - : int = 3
+#                                 class ['a] link :
+  'a ->
+  object ('b)
+    val mutable next : 'b option
+    val mutable x : 'a
+    method append : 'b option -> unit
+    method next : 'b option
+    method set_next : 'b option -> unit
+    method set_x : 'a -> unit
+    method x : 'a
+  end
+#                   class ['a] double_link :
+  'a ->
+  object ('b)
+    val mutable next : 'b option
+    val mutable prev : 'b option
+    val mutable x : 'a
+    method append : 'b option -> unit
+    method next : 'b option
+    method prev : 'b option
+    method set_next : 'b option -> unit
+    method set_prev : 'b option -> unit
+    method set_x : 'a -> unit
+    method x : 'a
+  end
+#           val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = 
+#                                       class calculator :
+  unit ->
+  object ('a)
+    val mutable acc : float
+    val mutable arg : float
+    val mutable equals : 'a -> float
+    method acc : float
+    method add : 'a
+    method arg : float
+    method enter : float -> 'a
+    method equals : float
+    method sub : 'a
+  end
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+#                       class calculator :
+  unit ->
+  object ('a)
+    val mutable acc : float
+    val mutable arg : float
+    val mutable equals : 'a -> float
+    method acc : float
+    method add : 'a
+    method arg : float
+    method enter : float -> 'a
+    method equals : float
+    method sub : 'a
+  end
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+#                                 class calculator :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_add :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_sub :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+#   val calculator : calculator = 
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+# 
diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference
index 6be5b694..128d1be7 100644
--- a/testsuite/tests/typing-objects/Exemples.ml.reference
+++ b/testsuite/tests/typing-objects/Exemples.ml.reference
@@ -231,7 +231,7 @@ is not a subtype of
 #   val c3 : int_comparable3 = 
 # - : unit = ()
 # Characters 25-27:
-  (new sorted_list ())#add c3;;   (* Echec : leq n'est pas binaire *)
+  (new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
                            ^^
 Error: This expression has type
          int_comparable3 =
diff --git a/testsuite/tests/typing-objects/Makefile b/testsuite/tests/typing-objects/Makefile
index 9add1557..5f42b705 100644
--- a/testsuite/tests/typing-objects/Makefile
+++ b/testsuite/tests/typing-objects/Makefile
@@ -1,3 +1,4 @@
-include ../../makefiles/Makefile.toplevel
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
 
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index 19d20d88..c7a5cb3d 100644
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -302,3 +302,26 @@ end;;
 let x = new d () in x#n, x#o;;
 
 class c () = object method virtual m : int method private m = 1 end;;
+
+(* Marshaling (cf. PR#5436) *)
+
+Oo.id (object end);;
+Oo.id (object end);;
+Oo.id (object end);;
+let o = object end in
+  let s = Marshal.to_string o [] in
+  let o' : < > = Marshal.from_string s 0 in
+  let o'' : < > = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'');;
+
+let o = object val x = 33 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] 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);;
+
+let o = object val x = 33 val y = 44 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] in
+  let o' :  = 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);;
diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
new file mode 100644
index 00000000..1f891253
--- /dev/null
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -0,0 +1,302 @@
+
+#   - : < x : int > ->
+    < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
+= 
+#               class ['a] c : unit -> object constraint 'a = int method f : int c end
+and ['a] d : unit -> object constraint 'a = int method f : int c end
+#                 Characters 238-275:
+  ........d () = object
+    inherit ['a] c ()
+  end..
+Error: Some type variables are unbound in this type:
+         class d : unit -> object method f : 'a -> unit end
+       The method f has type 'a -> unit where 'a is unbound
+#             class virtual c : unit -> object  end
+and ['a] d :
+  unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
+#                 class ['a] c : unit -> object constraint 'a = int end
+and ['a] d : unit -> object constraint 'a = int #c end
+# *             class ['a] c :
+  'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
+# - : ('a c as 'a) -> 'a = 
+# *           Characters 134-176:
+  ......x () = object
+    method virtual f : int
+  end..
+Error: This class should be virtual. The following methods are undefined : f
+#               Characters 139-147:
+  class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
+                                                   ^^^^^^^^
+Error: This pattern cannot match self: it only matches values of type
+       < f : int >
+#           Characters 38-110:
+  ......['a] c () = object
+    constraint 'a = int
+    method f x = (x : bool c)
+  end..
+Error: The abbreviation c is used with parameters bool c
+       wich are incompatible with constraints int c
+#             class ['a, 'b] c :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     class ['a, 'b] d :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     val x : '_a list ref = {contents = []}
+#     Characters 6-50:
+  ......['a] c () = object
+    method f = (x : 'a)
+  end..
+Error: The type of this class,
+       class ['a] c :
+         unit -> object constraint 'a = '_b list ref method f : 'a end,
+       contains type variables that cannot be generalized
+#       Characters 24-52:
+  type 'a c = 
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of d, type int c should be 'a c
+#   type 'a c = < f : 'a c; g : 'a d >
+and 'a d = < f : 'a c >
+#   type 'a c = < f : 'a c >
+and 'a d = < f : int c >
+#   type 'a u = < x : 'a >
+and 'a t = 'a t u
+#   Characters 18-32:
+  and 'a t = 'a t u;;
+     ^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+# type 'a u = 'a
+# Characters 5-18:
+  type t = t u * t u;;
+       ^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+#   type t = < x : 'a > as 'a
+# type 'a u = 'a
+# - : t -> t u -> bool = 
+# - : t -> t u -> bool = 
+#                         module M :
+  sig
+    class ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        constraint 'a = int -> bool
+        val x : float list
+        val y : 'b
+        method f : 'a -> unit
+        method g : 'b
+      end
+  end
+#                   module M' :
+  sig
+    class virtual ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        constraint 'a = int -> bool
+        val x : float list
+        val y : 'b
+        method f : 'a -> unit
+        method g : 'b
+      end
+  end
+# class ['a, 'b] d :
+  unit ->
+  'b ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# class ['a, 'b] e :
+  unit ->
+  'b ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# - : string = "a"
+# - : int = 10
+# - : float = 7.1
+# # - : bool = true
+#     module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
+#   module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
+# - : ('a #M.c as 'b) -> 'b = 
+# - : ('a #M'.c as 'b) -> 'b = 
+# class ['a] c : 'a #c -> object  end
+# class ['a] c : 'a #c -> object  end
+#     class c : unit -> object method f : int end
+and d : unit -> object method f : int end
+# class e : unit -> object method f : int end
+# - : int = 2
+# Characters 30-34:
+  class c () = object val x = - true val y = -. () end;;
+                                ^^^^
+Error: This expression has type bool but an expression was expected of type
+         int
+#   class c : unit -> object method f : int method g : int method h : int end
+# class d : unit -> object method h : int method i : int method j : int end
+#               class e :
+  unit ->
+  object
+    method f : int
+    method g : int
+    method h : int
+    method i : int
+    method j : int
+  end
+# val e : e = 
+# - : int * int * int * int * int = (1, 3, 2, 2, 3)
+#   class c : 'a -> object val a : 'a val x : int val y : int val z : int end
+# class d : 'a -> object val b : 'a val t : int val u : int val z : int end
+#                             Characters 43-46:
+    inherit c 5
+            ^^^
+Warning 13: the following instance variables are overridden by the class c :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 53-58:
+    val y = 3
+        ^^^^^
+Warning 13: the instance variable y is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 81-84:
+    inherit d 7
+            ^^^
+Warning 13: the following instance variables are overridden by the class d :
+  t z
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 91-96:
+    val u = 3
+        ^^^^^
+Warning 13: the instance variable u is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class e :
+  unit ->
+  object
+    val a : int
+    val b : int
+    val t : int
+    val u : int
+    val x : int
+    val y : int
+    val z : int
+    method a : int
+    method b : int
+    method t : int
+    method u : int
+    method x : int
+    method y : int
+    method z : int
+  end
+# val e : e = 
+# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
+#             class c :
+  int ->
+  int -> object val x : int val y : int method x : int method y : int end
+# class d :
+  int ->
+  int -> object val x : int val y : int method x : int method y : int end
+# - : int * int = (1, 2)
+# - : int * int = (1, 2)
+#     class ['a] c : 'a -> object  end
+# - : 'a -> 'a c = 
+#     * * * * * * * * * * * * * * * * * * * * *                             module M : sig class c : unit -> object method xc : int end end
+#         class d : unit -> object val x : int method xc : int method xd : int end
+# - : int * int = (1, 2)
+#         Characters 7-156:
+  ......virtual ['a] matrix (sz, init : int * 'a) = object
+    val m = Array.create_matrix sz sz init
+    method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+  end..
+Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
+       but is used with type < m : 'a array array; .. >
+#   class c : unit -> object method m : c end
+# - : c = 
+# module M : sig class c : unit -> object method m : c end end
+# - : M.c = 
+#   type uu = A of int | B of (< leq : 'a > as 'a)
+#   class virtual c : unit -> object ('a) method virtual m : 'a end
+#         module S : sig val f : (#c as 'a) -> 'a end
+#         Characters 12-43:
+  ............struct
+    let f (x : #c) = x
+  end......
+Error: Signature mismatch:
+       Modules do not match:
+         sig val f : (#c as 'a) -> 'a end
+       is not included in
+         sig val f : #c -> #c end
+       Values do not match:
+         val f : (#c as 'a) -> 'a
+       is not included in
+         val f : #c -> #c
+#   Characters 32-55:
+  module M = struct type t = int class t () = object end end;;
+                                 ^^^^^^^^^^^^^^^^^^^^^^^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#   - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = 
+#   Characters 10-39:
+  fun x -> (x : int -> bool :> 'a -> 'a);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+# Characters 9-40:
+  fun x -> (x : int -> bool :> int -> int);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+# - : <  > -> <  > = 
+# - : < .. > -> <  > = 
+#   val x : '_a list ref = {contents = []}
+#   module F : functor (X : sig  end) -> sig type t = int end
+# - : < m : int > list ref = {contents = []}
+#   type 'a t
+# Characters 9-19:
+  fun (x : 'a t as 'a) -> ();;
+           ^^^^^^^^^^
+Error: This alias is bound to type 'a t but is used as an instance of type 'a
+       The type variable 'a occurs inside 'a t
+# Characters 19-20:
+  fun (x : 'a t) -> (x : 'a); ();;
+                     ^
+Error: This expression has type 'a t but an expression was expected of type
+         'a
+       The type variable 'a occurs inside 'a t
+# type 'a t = < x : 'a >
+# - : ('a t as 'a) -> unit = 
+# Characters 18-26:
+  fun (x : 'a t) -> (x : 'a); ();;
+                    ^^^^^^^^
+Warning 10: this expression should have type unit.
+- : ('a t as 'a) t -> unit = 
+#         class ['a] c :
+  unit ->
+  object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
+#       class ['a] c :
+  unit ->
+  object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
+#         class c : unit -> object method private m : int method n : int end
+#         class d :
+  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 = 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)
+# 
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index 74b1c25f..cbeaa614 100644
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -134,8 +134,8 @@ Error: The type abbreviation t is cyclic
 # # - : bool = true
 #     module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
 #   module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
-# - : ('b #M.c as 'a) -> 'a = 
-# - : ('b #M'.c as 'a) -> 'a = 
+# - : ('a #M.c as 'b) -> 'b = 
+# - : ('a #M'.c as 'b) -> 'b = 
 # class ['a] c : 'a #c -> object  end
 # class ['a] c : 'a #c -> object  end
 #     class c : unit -> object method f : int end
@@ -268,18 +268,20 @@ Error: Type int -> bool is not a subtype of int -> int
   fun (x : 'a t as 'a) -> ();;
            ^^^^^^^^^^
 Error: This alias is bound to type 'a t but is used as an instance of type 'a
+       The type variable 'a occurs inside 'a t
 # Characters 19-20:
   fun (x : 'a t) -> (x : 'a); ();;
                      ^
 Error: This expression has type 'a t but an expression was expected of type
          'a
+       The type variable 'a occurs inside 'a t
 # type 'a t = < x : 'a >
 # - : ('a t as 'a) -> unit = 
 # Characters 18-26:
   fun (x : 'a t) -> (x : 'a); ();;
                     ^^^^^^^^
 Warning 10: this expression should have type unit.
-- : ('a t as 'a) -> unit = 
+- : ('a t as 'a) t -> unit = 
 #         class ['a] c :
   unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end
 #       class ['a] c :
@@ -290,4 +292,10 @@ 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 = 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)
 # 
diff --git a/testsuite/tests/typing-poly-bugs/Makefile b/testsuite/tests/typing-poly-bugs/Makefile
new file mode 100644
index 00000000..1b07f206
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-poly-bugs/pr5322_ok.ml b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml
new file mode 100644
index 00000000..a24a6769
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml
@@ -0,0 +1,7 @@
+type 'par t = 'par
+module M : sig val x :  end =
+  struct let x :  = Obj.magic () end
+
+let ident v = v
+class alias = object method alias : 'a . 'a t -> 'a = ident end
+
diff --git a/testsuite/tests/typing-poly/.svnignore b/testsuite/tests/typing-poly/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/typing-poly/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < ] as 'a> :>  ] as 'a>);;
 
+(* Keep sharing the epsilons *)
+let f x = if true then (x : < m : 'a. 'a -> 'a >) else x;;
+fun x -> (f x)#m;; (* Warning 18 *)
+let f (x, y) = if true then (x : < m : 'a. 'a -> 'a >) else x;;
+fun x -> (f (x,x))#m;; (* Warning 18 *)
+let f x = if true then [| (x : < m : 'a. 'a -> 'a >) |] else [|x|];;
+fun x -> (f x).(0)#m;; (* Warning 18 *)
+
 (* Not really principal? *)
 class c = object method id : 'a. 'a -> 'a = fun x -> x end;;
 type u = c option;;
 let just = function None -> failwith "just" | Some x -> x;;
 let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
 let g x =
-  let none = match None with y -> ignore [y;(None:u)]; y in
+  let none = (fun y -> ignore [y;(None:u)]; y) None in
   let x = List.hd [Some x; none] in (just x)#id;;
 let h x =
   let none = let y = None in ignore [y;(None:u)]; y in
   let x = List.hd [Some x; none] in (just x)#id;;
 
+(* Only solved for parameterless abbreviations *)
+type 'a u = c option;;
+let just = function None -> failwith "just" | Some x -> x;;
+let f x = let l = [Some x; (None : _ u)] in (just(List.hd l))#id;;
+
 (* polymorphic recursion *)
 
 let rec f : 'a. 'a -> _ = fun x -> 1 and g x = f x;;
@@ -620,5 +633,21 @@ let l : t = { f = lazy (raise Not_found)};;
 
 (* variant *)
 type t = {f: 'a. 'a -> unit};;
-{f=fun ?x y -> ()};;
-{f=fun ?x y -> y};; (* fail *)
+let f ?x y = () in {f};;
+let f ?x y = y in {f};; (* fail *)
+
+(* Polux Moon caml-list 2011-07-26 *)
+module Polux = struct
+  type 'par t = 'par
+  let ident v = v
+  class alias = object method alias : 'a . 'a t -> 'a = ident end
+  let f (x : ) = (x : )
+end;;
+
+(* PR#5560 *)
+
+let (a, b) = (raise Exit : int * int);;
+type t = { foo : int }
+let {foo} = (raise Exit : t);;
+type s = A of int
+let (A x) = (raise Exit : s);;
diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference
index 63281ae0..55bfd0f4 100644
--- a/testsuite/tests/typing-poly/poly.ml.principal.reference
+++ b/testsuite/tests/typing-poly/poly.ml.principal.reference
@@ -3,17 +3,17 @@
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
 # val f : 'a list -> 'a fold = 
 # - : int = 6
-#               class ['a] ilist :
-  'a list ->
-  object ('b)
-    val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+#               class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
   end
 #         class virtual ['a] vlist :
-  object ('b)
-    method virtual add : 'a -> 'b
-    method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #             class ilist2 :
   int list ->
@@ -25,52 +25,52 @@
 #             val ilist2 : 'a list -> 'a vlist = 
 #             class ['a] ilist3 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #               class ['a] ilist4 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist5 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist6 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #         class ['a] onil :
-  object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #             class ['a] ocons :
   hd:'a ->
   tl:'a olist ->
   object
     val hd : 'a
     val tl : 'a olist
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
 #               class ['a] ostream :
   hd:'a ->
   tl:'a ostream ->
   object
     val hd : 'a
-    val tl : < empty : bool; fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b >
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
     method empty : bool
     method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
@@ -123,9 +123,9 @@ val d : float = 11.4536240470737098
 #   Characters 41-42:
   let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
                                            ^
-Error: This expression has type < m : 'a. 'a -> 'a list >
-       but an expression was expected of type < m : 'a. 'a -> 'b >
-       The universal variable 'a would escape its scope
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
 #           class id : object method id : 'a -> 'a end
 #         class type id_spec = object method id : 'a -> 'a end
 #       class id_impl : object method id : 'a -> 'a end
@@ -142,13 +142,13 @@ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
 #           Characters 80-85:
     method id _ = x
               ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #                 Characters 92-159:
   ............x =
       match r with
         None -> r <- Some x; x
       | Some y -> y
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #         class c : object method m : 'a -> 'b -> 'a end
 #     val f1 : id -> int * bool = 
 #   val f2 : id -> int * bool = 
@@ -175,9 +175,9 @@ val f4 : id -> int * bool = 
 Error: The type abbreviation foo is cyclic
 #     class ['a] bar : 'a -> object  end
 #   type 'a foo = 'a foo bar
-#   - : (< m : 'b. 'b * 'a > as 'a) -> 'c * (< m : 'e. 'e * 'd > as 'd) = 
-# - : (< m : 'b. 'a * 'b list > as 'a) ->
-    (< m : 'd. 'c * 'd list > as 'c) * 'e list
+#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = 
+# - : (< m : 'a. 'b * 'a list > as 'b) ->
+    (< m : 'a. 'c * 'a list > as 'c) * 'd list
 = 
 # val f :
   (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
@@ -186,11 +186,11 @@ Error: The type abbreviation foo is cyclic
 # - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
     (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
 = 
-# - : (< m : 'b. 'b * < p : 'd. 'd * 'c * 'a > as 'c > as 'a) ->
+# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
     ('f *
-     < p : 'g.
-             'g * 'e *
-             (< m : 'i. 'i * < p : 'k. 'k * 'j * 'h > as 'j > as 'h) >
+     < p : 'b.
+             'b * 'e *
+             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
      as 'e)
 = 
 #   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
@@ -199,14 +199,14 @@ Error: The type abbreviation foo is cyclic
 #   type record = { r : < id : 'a. 'a -> 'a >; }
 # - : record -> 'a -> 'a = 
 # - : record -> 'a -> 'a = 
-#       class myself : object ('a) method self : 'b -> 'a end
+#       class myself : object ('b) method self : 'a -> 'b end
 #                       class number :
-  object ('a)
+  object ('b)
     val num : int
     method num : int
-    method prev : 'a
-    method succ : 'a
-    method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
   end
 #     val id : 'a -> 'a = 
 #       class c : object method id : 'a -> 'a end
@@ -216,14 +216,14 @@ Error: The type abbreviation foo is cyclic
     val mutable count : int
     method count : int
     method id : 'a -> 'a
-    method old : 'b -> 'b
+    method old : 'a -> 'a
   end
 #             class ['a] olist :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method cons : 'a -> 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
   end
 #   val sum : int #olist -> int = 
 #   val count : 'a #olist -> int = 
@@ -244,16 +244,16 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
 # Characters 17-25:
   let bad = {bad = ref None};;
                    ^^^^^^^^
-Error: This field value has type 'a option ref which is less general than
-         'b. 'b option ref
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
 # type bad2 = { mutable bad2 : 'a. 'a option ref option; }
 # val bad2 : bad2 = {bad2 = None}
 # Characters 13-28:
   bad2.bad2 <- Some (ref None);;
                ^^^^^^^^^^^^^^^
-Error: This field value has type 'a option ref option
-       which is less general than 'b. 'b option ref option
-#       val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = 
+Error: This field value has type 'b option ref option
+       which is less general than 'a. 'a option ref option
+#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
 # val f :
   < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
   (< p : int * 'c > as 'c) -> unit = 
@@ -265,10 +265,10 @@ Error: This field value has type 'a option ref option
 #           Characters 145-166:
   object method virtual visit : 'a.('a visitor -> 'a) end;;
                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This type scheme cannot quantify 'a :
-it escapes this scope.
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
 #                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
+type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
 class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
 type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
 #     Characters 20-25:
@@ -281,7 +281,7 @@ type t = [ `A of t a ]
   type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
                                                     ^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type ('a, 'b) t should be an instance of ('c, 'c) t
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
 #     type 'a t = 'a
 and u = int t
 #     type 'a t constraint 'a = int
@@ -289,7 +289,7 @@ and u = int t
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of int t
+       Type 'a u t should be an instance of int t
 # type 'a u = 'a constraint 'a = int
 and 'a v = 'a u t constraint 'a = int
 #     type g = int
@@ -298,7 +298,7 @@ and 'a v = 'a u t constraint 'a = int
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of g t
+       Type 'a u t should be an instance of g t
 # type 'a u = 'a constraint 'a = g
 and 'a v = 'a u t constraint 'a = int
 #     Characters 38-58:
@@ -350,10 +350,10 @@ Warning 11: this match case is unused.
   type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] 
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type
-([> `B of 'a ], 'a) b as 'a
-should be an instance of
-(('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
+       Type
+       ([> `B of 'a ], 'a) b as 'a
+       should be an instance of
+       (('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
 #     *                           class type ['a, 'b] a =
   object
     constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
@@ -412,9 +412,9 @@ Error: This object is expected to have type < x : int; .. >
 #         Characters 76-77:
     (x :  > as 'bar) >);;
      ^
-Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
        but an expression was expected of type
-         < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) >
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
        Types for method m are incompatible
 #         Characters 176-177:
   let f (x : foo') = (x : bar');;
@@ -422,70 +422,70 @@ Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
 Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
        but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > 
+         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'b. 'b * 'a bar > 
+         < m : 'c. 'c * 'a bar > 
        Types for method m are incompatible
 #     Characters 67-68:
     (x : )> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 66-67:
     (x : )> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 51-52:
     (x :  as 'bar)>);;
      ^
 Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
        but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
        Types for method m are incompatible
 #     Characters 14-115:
   ....(x :  ('a *  'bar> as 'bar)>
          :>  ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) >
+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 
 #       Characters 88-150:
   = struct let f (x :  as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
        is not included in
          sig
-           val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
          end
        Values do not match:
-         val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
        is not included in
-         val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
 #     Characters 78-132:
   = struct type t =  as 'foo end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end
+         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
        is not included in
-         sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end
+         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
        Type declarations do not match:
-         type t = < m : 'b. 'b * ('b * 'a) > as 'a
+         type t = < m : 'a. 'a * ('a * 'b) > as 'b
        is not included in
-         type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
 #     module M : sig type 'a t type u = < m : 'a. 'a t > end
 #   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #         val f :
-  (< m : 'b. 'b -> (< m : 'b. 'b -> 'c * <  > > as 'c) * < .. >; .. > as 'a) ->
-  'a -> bool = 
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = 
 #         type t = [ `A | `B ]
 # type v = private [> t ]
 # - : t -> v = 
@@ -514,12 +514,12 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
          < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
 #     val f2 :
   < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = 
+  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = 
 #     Characters 13-107:
   ..(x : ;..> as 'a) -> int>
       :> ;..> as 'b) -> int>)..
 Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'a. (< p : < a : int >; .. > as 'a) -> int > 
+       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
 # Characters 11-55:
   let f4 x = (x : ;..> :> ;..>);;
              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -528,18 +528,47 @@ Error: Type < p : < a : int; b : int >; .. > is not a subtype of
 The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'a. [< `A of <  > ] as 'a > = 
+  < m : 'b. [< `A of <  > ] as 'b > = 
 #   Characters 13-83:
     (x :  ] as 'a> :>  ] as 'a>);;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'a. [< `A of < p : int > ] as 'a > 
+         < m : 'b. [< `A of < p : int > ] as 'b > 
+#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
+# Characters 9-16:
+  fun x -> (f x)#m;; (* Warning 18 *)
+           ^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
+# Characters 9-20:
+  fun x -> (f (x,x))#m;; (* Warning 18 *)
+           ^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
+# Characters 9-20:
+  fun x -> (f x).(0)#m;; (* Warning 18 *)
+           ^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
 #     class c : object method id : 'a -> 'a end
 # type u = c option
 # val just : 'a option -> 'a = 
-# val f : c -> 'a -> 'a = 
-#     val g : c -> 'a -> 'a = 
+# Characters 42-62:
+  let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
+                                            ^^^^^^^^^^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+val f : c -> 'a -> 'a = 
+#     Characters 101-112:
+    let x = List.hd [Some x; none] in (just x)#id;;
+                                      ^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+val g : c -> 'a -> 'a = 
 #     val h : < id : 'a; .. > -> 'a = 
+#     type 'a u = c option
+# val just : 'a option -> 'a = 
+# val f : c -> 'a -> 'a = 
 #       val f : 'a -> int = 
 val g : 'a -> int = 
 # type 'a t = Leaf of 'a | Node of ('a * 'a) t
@@ -548,7 +577,7 @@ val g : 'a -> int = 
     function Leaf _ -> 1 | Node x -> 1 + d x
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> int which is less general than
-         'b. 'b t -> int
+         'a0. 'a0 t -> int
 #   Characters 34-78:
     function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -558,12 +587,12 @@ Error: This definition has type int t -> int which is less general than
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> 'a which is less general than
-         'b. 'b t -> 'a
+         'a0. 'a0 t -> 'a
 #   Characters 38-78:
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a. 'a t -> 'a which is less general than
-         'b 'c. 'c t -> 'b
+Error: This definition has type 'b. 'b t -> 'b which is less general than
+         'b 'a. 'a t -> 'b
 #   val r : 'a list * '_b list ref = ([], {contents = []})
 val q : unit -> 'a list * '_b list ref = 
 # val f : 'a -> 'a = 
@@ -591,9 +620,19 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = 
 val l : t = {f = }
 #     type t = { f : 'a. 'a -> unit; }
 # - : t = {f = }
-# Characters 3-16:
-  {f=fun ?x y -> y};; (* fail *)
-     ^^^^^^^^^^^^^
+# Characters 19-20:
+  let f ?x y = y in {f};; (* fail *)
+                     ^
 Error: This field value has type unit -> unit which is less general than
          'a. 'a -> unit
+#               module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+#       Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
 # 
diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference
index 6e4fce85..89d050b3 100644
--- a/testsuite/tests/typing-poly/poly.ml.reference
+++ b/testsuite/tests/typing-poly/poly.ml.reference
@@ -3,17 +3,17 @@
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
 # val f : 'a list -> 'a fold = 
 # - : int = 6
-#               class ['a] ilist :
-  'a list ->
-  object ('b)
-    val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+#               class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
   end
 #         class virtual ['a] vlist :
-  object ('b)
-    method virtual add : 'a -> 'b
-    method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #             class ilist2 :
   int list ->
@@ -25,54 +25,54 @@
 #             val ilist2 : 'a list -> 'a vlist = 
 #             class ['a] ilist3 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #               class ['a] ilist4 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist5 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist6 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #         class ['a] onil :
-  object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #             class ['a] ocons :
   hd:'a ->
   tl:'a olist ->
   object
     val hd : 'a
     val tl : 'a olist
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
 #               class ['a] ostream :
   hd:'a ->
   tl:'a ostream ->
   object
     val hd : 'a
-    val tl : 'a ostream
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
     method empty : bool
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
 #                   class ['a] ostream1 :
   hd:'a ->
@@ -119,13 +119,13 @@ val p1 : point = 
 val cp : color_point = 
 val c : circle = 
 val d : float = 11.4536240470737098
-#   val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
+#   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 >)
                                            ^
-Error: This expression has type < m : 'a. 'a -> 'a list >
-       but an expression was expected of type < m : 'a. 'a -> 'b >
-       The universal variable 'a would escape its scope
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
 #           class id : object method id : 'a -> 'a end
 #         class type id_spec = object method id : 'a -> 'a end
 #       class id_impl : object method id : 'a -> 'a end
@@ -142,13 +142,13 @@ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
 #           Characters 80-85:
     method id _ = x
               ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #                 Characters 92-159:
   ............x =
       match r with
         None -> r <- Some x; x
       | Some y -> y
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #         class c : object method m : 'a -> 'b -> 'a end
 #     val f1 : id -> int * bool = 
 #   val f2 : id -> int * bool = 
@@ -167,16 +167,16 @@ Error: This expression has type bool but an expression was expected of type
 Error: The type abbreviation foo is cyclic
 #     class ['a] bar : 'a -> object  end
 #   type 'a foo = 'a foo bar
-#   - : (< m : 'b. 'b * 'a > as 'a) -> 'c * 'a = 
-# - : (< m : 'b. 'a * 'b list > as 'a) -> 'a * 'c list = 
+#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = 
+# - : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = 
 # val f :
   (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
   'a * (< n : 'c; .. > as 'c) = 
 # - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
     (< m : 'c; n : 'a; .. > as 'c)
 = 
-# - : (< m : 'b. 'b * < p : 'd. 'd * 'c * 'a > as 'c > as 'a) ->
-    ('f * < p : 'g. 'g * 'e * 'a > as 'e)
+# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
 = 
 #   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
 #   type sum = T of < id : 'a. 'a -> 'a >
@@ -184,14 +184,14 @@ Error: The type abbreviation foo is cyclic
 #   type record = { r : < id : 'a. 'a -> 'a >; }
 # - : record -> 'a -> 'a = 
 # - : record -> 'a -> 'a = 
-#       class myself : object ('a) method self : 'b -> 'a end
+#       class myself : object ('b) method self : 'a -> 'b end
 #                       class number :
-  object ('a)
+  object ('b)
     val num : int
     method num : int
-    method prev : 'a
-    method succ : 'a
-    method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
   end
 #     val id : 'a -> 'a = 
 #       class c : object method id : 'a -> 'a end
@@ -201,14 +201,14 @@ Error: The type abbreviation foo is cyclic
     val mutable count : int
     method count : int
     method id : 'a -> 'a
-    method old : 'b -> 'b
+    method old : 'a -> 'a
   end
 #             class ['a] olist :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method cons : 'a -> 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
   end
 #   val sum : int #olist -> int = 
 #   val count : 'a #olist -> int = 
@@ -229,16 +229,16 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
 # Characters 17-25:
   let bad = {bad = ref None};;
                    ^^^^^^^^
-Error: This field value has type 'a option ref which is less general than
-         'b. 'b option ref
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
 # type bad2 = { mutable bad2 : 'a. 'a option ref option; }
 # val bad2 : bad2 = {bad2 = None}
 # Characters 13-28:
   bad2.bad2 <- Some (ref None);;
                ^^^^^^^^^^^^^^^
-Error: This field value has type 'a option ref option
-       which is less general than 'b. 'b option ref option
-#       val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = 
+Error: This field value has type 'b option ref option
+       which is less general than 'a. 'a option ref option
+#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
 # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = 
 #       type 'a t = [ `A of 'a ]
 #       class c : object method m : ([> 'a t ] as 'a) -> unit end
@@ -248,10 +248,10 @@ Error: This field value has type 'a option ref option
 #           Characters 145-166:
   object method virtual visit : 'a.('a visitor -> 'a) end;;
                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This type scheme cannot quantify 'a :
-it escapes this scope.
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
 #                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
+type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
 class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
 type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
 #     Characters 20-25:
@@ -264,7 +264,7 @@ type t = [ `A of t a ]
   type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
                                                     ^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type ('a, 'b) t should be an instance of ('c, 'c) t
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
 #     type 'a t = 'a
 and u = int t
 #     type 'a t constraint 'a = int
@@ -272,7 +272,7 @@ and u = int t
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of int t
+       Type 'a u t should be an instance of int t
 # type 'a u = 'a constraint 'a = int
 and 'a v = 'a u t constraint 'a = int
 #     type g = int
@@ -281,7 +281,7 @@ and 'a v = 'a u t constraint 'a = int
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of g t
+       Type 'a u t should be an instance of g t
 # type 'a u = 'a constraint 'a = g
 and 'a v = 'a u t constraint 'a = int
 #     Characters 38-58:
@@ -333,10 +333,10 @@ Warning 11: this match case is unused.
   type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] 
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type
-([> `B of 'a ], 'a) b as 'a
-should be an instance of
-(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
+       Type
+       ([> `B of 'a ], 'a) b as 'a
+       should be an instance of
+       (('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
 #     *                           class type ['a, 'b] a =
   object
     constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
@@ -395,9 +395,9 @@ Error: This object is expected to have type < x : int; .. >
 #         Characters 76-77:
     (x :  > as 'bar) >);;
      ^
-Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
        but an expression was expected of type
-         < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) >
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
        Types for method m are incompatible
 #         Characters 176-177:
   let f (x : foo') = (x : bar');;
@@ -405,70 +405,70 @@ Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
 Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
        but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > 
+         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'b. 'b * 'a bar > 
+         < m : 'c. 'c * 'a bar > 
        Types for method m are incompatible
 #     Characters 67-68:
     (x : )> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 66-67:
     (x : )> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 51-52:
     (x :  as 'bar)>);;
      ^
 Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
        but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
        Types for method m are incompatible
 #     Characters 14-115:
   ....(x :  ('a *  'bar> as 'bar)>
          :>  ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) >
+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 
 #       Characters 88-150:
   = struct let f (x :  as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
        is not included in
          sig
-           val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
          end
        Values do not match:
-         val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
        is not included in
-         val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
 #     Characters 78-132:
   = struct type t =  as 'foo end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end
+         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
        is not included in
-         sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end
+         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
        Type declarations do not match:
-         type t = < m : 'b. 'b * ('b * 'a) > as 'a
+         type t = < m : 'a. 'a * ('a * 'b) > as 'b
        is not included in
-         type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
 #     module M : sig type 'a t type u = < m : 'a. 'a t > end
 #   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #         val f :
-  (< m : 'b. 'b -> (< m : 'b. 'b -> 'c * <  > > as 'c) * < .. >; .. > as 'a) ->
-  'a -> bool = 
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = 
 #         type t = [ `A | `B ]
 # type v = private [> t ]
 # - : t -> v = 
@@ -497,12 +497,12 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
          < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
 #     val f2 :
   < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = 
+  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = 
 #     Characters 13-107:
   ..(x : ;..> as 'a) -> int>
       :> ;..> as 'b) -> int>)..
 Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'a. (< p : < a : int >; .. > as 'a) -> int > 
+       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
 # Characters 11-55:
   let f4 x = (x : ;..> :> ;..>);;
              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -511,18 +511,27 @@ Error: Type < p : < a : int; b : int >; .. > is not a subtype of
 The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'a. [< `A of <  > ] as 'a > = 
+  < m : 'b. [< `A of <  > ] as 'b > = 
 #   Characters 13-83:
     (x :  ] as 'a> :>  ] as 'a>);;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'a. [< `A of < p : int > ] as 'a > 
+         < m : 'b. [< `A of < p : int > ] as 'b > 
+#     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 > = 
+# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
+# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
 #     class c : object method id : 'a -> 'a end
 # type u = c option
 # val just : 'a option -> 'a = 
 # val f : c -> 'a -> 'a = 
 #     val g : c -> 'a -> 'a = 
 #     val h : < id : 'a; .. > -> 'a = 
+#     type 'a u = c option
+# val just : 'a option -> 'a = 
+# val f : c -> 'a -> 'a = 
 #       val f : 'a -> int = 
 val g : 'a -> int = 
 # type 'a t = Leaf of 'a | Node of ('a * 'a) t
@@ -531,7 +540,7 @@ val g : 'a -> int = 
     function Leaf _ -> 1 | Node x -> 1 + d x
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> int which is less general than
-         'b. 'b t -> int
+         'a0. 'a0 t -> int
 #   Characters 34-78:
     function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -541,12 +550,12 @@ Error: This definition has type int t -> int which is less general than
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> 'a which is less general than
-         'b. 'b t -> 'a
+         'a0. 'a0 t -> 'a
 #   Characters 38-78:
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a. 'a t -> 'a which is less general than
-         'b 'c. 'c t -> 'b
+Error: This definition has type 'b. 'b t -> 'b which is less general than
+         'b 'a. 'a t -> 'b
 #   val r : 'a list * '_b list ref = ([], {contents = []})
 val q : unit -> 'a list * '_b list ref = 
 # val f : 'a -> 'a = 
@@ -574,9 +583,19 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = 
 val l : t = {f = }
 #     type t = { f : 'a. 'a -> unit; }
 # - : t = {f = }
-# Characters 3-16:
-  {f=fun ?x y -> y};; (* fail *)
-     ^^^^^^^^^^^^^
+# Characters 19-20:
+  let f ?x y = y in {f};; (* fail *)
+                     ^
 Error: This field value has type unit -> unit which is less general than
          'a. 'a -> unit
+#               module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+#       Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
 # 
diff --git a/testsuite/tests/typing-polyvariants-bugs-2/Makefile b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
index 3f01800f..9ecfbe38 100644
--- a/testsuite/tests/typing-polyvariants-bugs-2/Makefile
+++ b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 default:
 	@printf " ... testing 'pr3918':"
 	@($(OCAMLC) -c pr3918a.mli && $(OCAMLC) -c pr3918b.mli && $(OCAMLC) -c pr3918c.ml && echo " => passed") || echo " => failed"
 
 clean: defaultclean
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-polyvariants-bugs/Makefile b/testsuite/tests/typing-polyvariants-bugs/Makefile
index 9375ddba..1b07f206 100644
--- a/testsuite/tests/typing-polyvariants-bugs/Makefile
+++ b/testsuite/tests/typing-polyvariants-bugs/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+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 9375ddba..1b07f206 100644
--- a/testsuite/tests/typing-private-bugs/Makefile
+++ b/testsuite/tests/typing-private-bugs/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-private-bugs/pr5469_ok.ml b/testsuite/tests/typing-private-bugs/pr5469_ok.ml
new file mode 100644
index 00000000..74d35549
--- /dev/null
+++ b/testsuite/tests/typing-private-bugs/pr5469_ok.ml
@@ -0,0 +1,7 @@
+module M (T:sig type t end)
+ = struct type t = private { t : T.t } end
+module P
+ = struct
+       module T = struct type t end
+       module R = M(T)
+ end
diff --git a/testsuite/tests/typing-private/.svnignore b/testsuite/tests/typing-private/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/typing-private/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < F.t = 
+#   val f : F.t -> Foobar.t = 
 #   module M : sig type t = < m : int > end
 # module M1 : sig type t = private < m : int; .. > end
 # module M2 : sig type t = private < m : int; .. > end
@@ -73,7 +73,7 @@ Error: Signature mismatch:
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig type t = int val f : t -> t end
+         sig type t = int val f : int -> t end
        is not included in
          sig type t = private Foobar.t val f : int -> t end
        Type declarations do not match:
diff --git a/testsuite/tests/typing-recmod/Makefile b/testsuite/tests/typing-recmod/Makefile
index 9375ddba..1b07f206 100644
--- a/testsuite/tests/typing-recmod/Makefile
+++ b/testsuite/tests/typing-recmod/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-signatures/Makefile b/testsuite/tests/typing-signatures/Makefile
new file mode 100644
index 00000000..5f42b705
--- /dev/null
+++ b/testsuite/tests/typing-signatures/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+
diff --git a/testsuite/tests/typing-signatures/els.ml b/testsuite/tests/typing-signatures/els.ml
new file mode 100644
index 00000000..f3c9c793
--- /dev/null
+++ b/testsuite/tests/typing-signatures/els.ml
@@ -0,0 +1,92 @@
+(* Adapted from: An Expressive Language of Signatures
+   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+
+module type VALUE = sig
+  type value (* a Lua value *)
+  type state (* the state of a Lua interpreter *)
+  type usert (* a user-defined value *)
+end;;
+
+module type CORE0 = sig
+  module V : VALUE
+  val setglobal : V.state -> string -> V.value -> unit
+  (* five more functions common to core and evaluator *)
+end;;
+
+module type CORE = sig
+  include CORE0
+  val apply : V.value -> V.state -> V.value list -> V.value
+  (* apply function f in state s to list of args *)
+end;;
+
+module type AST = sig
+  module Value : VALUE
+  type chunk
+  type program
+  val get_value : chunk -> Value.value
+end;;
+
+module type EVALUATOR = sig
+  module Value : VALUE
+  module Ast : (AST with module Value := Value)
+  type state = Value.state
+  type value = Value.value
+  exception Error of string
+  val compile : Ast.program -> string
+  include CORE0 with module V := Value
+end;;
+
+module type PARSER = sig
+  type chunk
+  val parse : string -> chunk
+end;;
+
+module type INTERP = sig
+  include EVALUATOR
+  module Parser : PARSER with type chunk = Ast.chunk
+  val dostring : state -> string -> value list
+  val mk	: unit -> state
+end;;
+
+module type USERTYPE = sig
+  type t
+  val eq	: t -> t -> bool
+  val to_string : t -> string
+end;;
+
+module type TYPEVIEW = sig
+  type combined
+  type t
+  val map : (combined -> t) * (t -> combined)
+end;;
+
+module type COMBINED_COMMON = sig
+  module T : sig type t end
+  module TV1 : TYPEVIEW with type combined := T.t
+  module TV2 : TYPEVIEW with type combined := T.t
+end;;
+
+module type COMBINED_TYPE = sig
+  module T : USERTYPE
+  include COMBINED_COMMON with module T := T
+end;;
+
+module type BARECODE = sig
+  type state
+  val init : state -> unit
+end;;
+
+module USERCODE(X : TYPEVIEW) = struct
+  module type F =
+      functor (C : CORE with type V.usert = X.combined) ->
+        BARECODE with type state := C.V.state
+end;;
+
+module Weapon = struct type t end;;
+
+module type WEAPON_LIB = sig
+  type t = Weapon.t
+  module T : USERTYPE with type t = t
+  module Make :
+    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
+end;;
diff --git a/testsuite/tests/typing-signatures/els.ml.reference b/testsuite/tests/typing-signatures/els.ml.reference
new file mode 100644
index 00000000..91b4a32f
--- /dev/null
+++ b/testsuite/tests/typing-signatures/els.ml.reference
@@ -0,0 +1,93 @@
+
+# *             module type VALUE = sig type value type state type usert end
+#           module type CORE0 =
+  sig
+    module V : VALUE
+    val setglobal : V.state -> string -> V.value -> unit
+  end
+#           module type CORE =
+  sig
+    module V : VALUE
+    val setglobal : V.state -> string -> V.value -> unit
+    val apply : V.value -> V.state -> V.value list -> V.value
+  end
+#             module type AST =
+  sig
+    module Value : VALUE
+    type chunk
+    type program
+    val get_value : chunk -> Value.value
+  end
+#                   module type EVALUATOR =
+  sig
+    module Value : VALUE
+    module Ast :
+      sig type chunk type program val get_value : chunk -> Value.value end
+    type state = Value.state
+    type value = Value.value
+    exception Error of string
+    val compile : Ast.program -> string
+    val setglobal : Value.state -> string -> Value.value -> unit
+  end
+#         module type PARSER = sig type chunk val parse : string -> chunk end
+#             module type INTERP =
+  sig
+    module Value : VALUE
+    module Ast :
+      sig type chunk type program val get_value : chunk -> Value.value end
+    type state = Value.state
+    type value = Value.value
+    exception Error of string
+    val compile : Ast.program -> string
+    val setglobal : Value.state -> string -> Value.value -> unit
+    module Parser :
+      sig type chunk = Ast.chunk val parse : string -> chunk end
+    val dostring : state -> string -> value list
+    val mk : unit -> state
+  end
+#           module type USERTYPE =
+  sig type t val eq : t -> t -> bool val to_string : t -> string end
+#           module type TYPEVIEW =
+  sig type combined type t val map : (combined -> t) * (t -> combined) end
+#           module type COMBINED_COMMON =
+  sig
+    module T : sig type t end
+    module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+    module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+  end
+#         module type COMBINED_TYPE =
+  sig
+    module T : USERTYPE
+    module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+    module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+  end
+#         module type BARECODE = sig type state val init : state -> unit end
+#           module USERCODE :
+  functor (X : TYPEVIEW) ->
+    sig
+      module type F =
+        functor
+          (C : sig
+                 module V :
+                   sig type value type state type usert = X.combined end
+                 val setglobal : V.state -> string -> V.value -> unit
+                 val apply : V.value -> V.state -> V.value list -> V.value
+               end) ->
+          sig val init : C.V.state -> unit end
+    end
+#   module Weapon : sig type t end
+#             module type WEAPON_LIB =
+  sig
+    type t = Weapon.t
+    module T :
+      sig type t = t val eq : t -> t -> bool val to_string : t -> string end
+    module Make :
+      functor
+        (TV : sig
+                type combined
+                type t = t
+                val map : (combined -> t) * (t -> combined)
+              end) ->
+        USERCODE(TV).F
+  end
+# 
diff --git a/testsuite/tests/typing-sigsubst/Makefile b/testsuite/tests/typing-sigsubst/Makefile
new file mode 100644
index 00000000..5f42b705
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+
diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml
new file mode 100644
index 00000000..4cb22fa2
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml
@@ -0,0 +1,37 @@
+module type Printable = sig
+  type t
+  val print : Format.formatter -> t -> unit
+end;;
+module type Comparable = sig
+  type t
+  val compare : t -> t -> int
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t = t
+end;;
+module type PrintableComparable = sig
+  type t
+  include Printable with type t := t
+  include Comparable with type t := t
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t := t
+end;;
+module type ComparableInt = Comparable with type t := int;;
+module type S = sig type t val f : t -> t end;;
+module type S' = S with type t := int;;
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
+module type S1 = S with type 'a t := 'a list;;
+module type S2 = sig
+  type 'a dict = (string * 'a) list
+  include S with type 'a t := 'a dict
+end;;
+
+
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
+module M = struct type exp = string type arg = int end;;
+module type S' = S with module T := M;;
diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
new file mode 100644
index 00000000..3adcb82a
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
@@ -0,0 +1,36 @@
+
+#       module type Printable =
+  sig type t val print : Format.formatter -> t -> unit end
+#       module type Comparable = sig type t val compare : t -> t -> int end
+#       Characters 60-94:
+    include Comparable with type t = t
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#         module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+#       module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+# module type ComparableInt = sig val compare : int -> int -> int end
+# module type S = sig type t val f : t -> t end
+# module type S' = sig val f : int -> int end
+#   module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
+# module type S1 = sig val map : ('a -> 'b) -> 'a list -> 'b list end
+#       module type S2 =
+  sig
+    type 'a dict = (string * 'a) list
+    val map : ('a -> 'b) -> 'a dict -> 'b dict
+  end
+#       module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
+# module M : sig type exp = string type arg = int end
+# module type S' = sig val f : M.exp -> M.arg end
+# 
diff --git a/testsuite/tests/typing-typeparam/.svnignore b/testsuite/tests/typing-typeparam/.svnignore
deleted file mode 100755
index 4394099f..00000000
--- a/testsuite/tests/typing-typeparam/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . < `basename $$file ml`result; \
-	  diff -q `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \
 	done;
 
+promote: defaultpromote
+
 clean: defaultclean
 	@rm -f *.result $(EXECNAME)
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference
index e04d3e19..492ec7dc 100644
--- a/testsuite/tests/warnings/w01.reference
+++ b/testsuite/tests/warnings/w01.reference
@@ -1,7 +1,5 @@
 File "w01.ml", line 4, characters 12-14:
 Warning 2: this is not the end of a comment.
-File "w01.ml", line 9, characters 8-9:
-Warning 27: unused variable y.
 File "w01.ml", line 10, characters 0-3:
 Warning 5: this function application is partial,
 maybe some arguments are missing.
@@ -11,5 +9,7 @@ Here is an example of a value that is not matched:
 0
 File "w01.ml", line 25, characters 0-1:
 Warning 10: this expression should have type unit.
+File "w01.ml", line 9, characters 8-9:
+Warning 27: unused variable y.
 File "w01.ml", line 32, characters 2-3:
 Warning 11: this match case is unused.
diff --git a/tools/.cvsignore b/tools/.cvsignore
deleted file mode 100644
index cf3c6951..00000000
--- a/tools/.cvsignore
+++ /dev/null
@@ -1,25 +0,0 @@
-ocamldep
-ocamldep.opt
-ocamldep.bak
-ocamlprof
-opnames.ml
-dumpobj
-dumpapprox
-objinfo
-cvt_emit
-cvt_emit.bak
-cvt_emit.ml
-ocamlcp
-ocamlmktop
-primreq
-ocamldumpobj
-keywords
-lexer299.ml
-ocaml299to3
-ocamlmklib
-ocamlmklib.ml
-lexer301.ml
-scrapelabels
-addlabels
-myocamlbuild_config.ml
-objinfo_helper
diff --git a/tools/.depend b/tools/.depend
index 36c177ed..ecb74f69 100644
--- a/tools/.depend
+++ b/tools/.depend
@@ -1,62 +1,64 @@
-depend.cmi: ../parsing/parsetree.cmi
-profiling.cmi:
-addlabels.cmo: ../parsing/parsetree.cmi ../parsing/parse.cmi \
+depend.cmi : ../parsing/parsetree.cmi
+profiling.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 \
+addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
     ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi
-cvt_emit.cmo:
-cvt_emit.cmx:
-depend.cmo: ../parsing/parsetree.cmi ../parsing/longident.cmi \
-    ../parsing/location.cmi depend.cmi
-depend.cmx: ../parsing/parsetree.cmi ../parsing/longident.cmx \
-    ../parsing/location.cmx depend.cmi
-dumpobj.cmo: ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
-    ../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
-dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.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
-myocamlbuild_config.cmo:
-myocamlbuild_config.cmx:
-objinfo.cmo: ../utils/misc.cmi ../utils/config.cmi ../asmcomp/cmx_format.cmi \
-    ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmi \
-    ../bytecomp/bytesections.cmi
-objinfo.cmx: ../utils/misc.cmx ../utils/config.cmx ../asmcomp/cmx_format.cmi \
-    ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmx \
-    ../bytecomp/bytesections.cmx
-ocaml299to3.cmo:
-ocaml299to3.cmx:
-ocamlcp.cmo: ../driver/main_args.cmi
-ocamlcp.cmx: ../driver/main_args.cmx
-ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \
+cvt_emit.cmo :
+cvt_emit.cmx :
+depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \
+    ../parsing/longident.cmi ../parsing/location.cmi depend.cmi
+depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \
+    ../parsing/longident.cmx ../parsing/location.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
+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
+myocamlbuild_config.cmo :
+myocamlbuild_config.cmx :
+objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \
+    ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
+    ../asmcomp/clambda.cmi ../bytecomp/bytesections.cmi
+objinfo.cmx : ../utils/misc.cmx ../utils/config.cmx \
+    ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
+    ../asmcomp/clambda.cmx ../bytecomp/bytesections.cmx
+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 \
     ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \
     ../utils/config.cmi ../utils/clflags.cmi
-ocamldep.cmx: ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
+ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
     ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \
     ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \
     ../utils/config.cmx ../utils/clflags.cmx
-ocamlmklib.cmo: myocamlbuild_config.cmo
-ocamlmklib.cmx: myocamlbuild_config.cmx
-ocamlmktop.cmo: ../utils/ccomp.cmi
-ocamlmktop.cmx: ../utils/ccomp.cmx
-ocamlprof.cmo: ../utils/warnings.cmi ../parsing/syntaxerr.cmi \
+ocamlmklib.cmo : myocamlbuild_config.cmo
+ocamlmklib.cmx : myocamlbuild_config.cmx
+ocamlmktop.cmo : ../utils/ccomp.cmi
+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
-ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \
+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
-opnames.cmo:
-opnames.cmx:
-primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi
-primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi
-profiling.cmo: profiling.cmi
-profiling.cmx: profiling.cmi
-scrapelabels.cmo:
-scrapelabels.cmx:
+opnames.cmo :
+opnames.cmx :
+primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
+primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
+profiling.cmo : profiling.cmi
+profiling.cmx : profiling.cmi
+scrapelabels.cmo :
+scrapelabels.cmx :
diff --git a/tools/.ignore b/tools/.ignore
new file mode 100644
index 00000000..04ea00a0
--- /dev/null
+++ b/tools/.ignore
@@ -0,0 +1,26 @@
+ocamldep
+ocamldep.opt
+ocamldep.bak
+ocamlprof
+opnames.ml
+dumpobj
+dumpapprox
+objinfo
+cvt_emit
+cvt_emit.bak
+cvt_emit.ml
+ocamlcp
+ocamloptp
+ocamlmktop
+primreq
+ocamldumpobj
+keywords
+lexer299.ml
+ocaml299to3
+ocamlmklib
+ocamlmklib.ml
+lexer301.ml
+scrapelabels
+addlabels
+myocamlbuild_config.ml
+objinfo_helper
diff --git a/tools/Characters b/tools/Characters
deleted file mode 100644
index fb8e6868..00000000
--- a/tools/Characters
+++ /dev/null
@@ -1,16 +0,0 @@
-# Characters
-
-# $Id$
-
-# Usage:
-#    Characters n1 to n2
-#
-# Select the characters in the given interval, counting from the first
-# character of the current line, in the active window.
-#
-# Typical use is an error message of the form:
-#    File fff; Line lll; Characters yyy to zzz
-
-exit 1 if {#} ­ 3
-
-Find Ƥ!{1}:¤!`evaluate {3} - {1}` "{active}"
diff --git a/tools/DoMake b/tools/DoMake
deleted file mode 100644
index 2fce3401..00000000
--- a/tools/DoMake
+++ /dev/null
@@ -1,61 +0,0 @@
-# DoMake
-
-# $Id$
-
-# Execute the output of "Make -f Makefile.Mac -f Makefile.Mac.depend"
-# or "Make -f Makefile -f Makefile.depend" if "Makefile.Mac" does not exist
-# or "Make -f " if the "-f" option is given.
-
-# usage: domake [-quiet] [-f ]É 
-
-set echo 0
-
-set domake_quiet 0
-set domake_files ""
-
-loop
-  if "{1}" == "-quiet"
-    set domake_quiet 1
-    shift
-  else if "{1}" == "-f"
-    set domake_files "{domake_files} -f `quote "{2}"`"
-    shift 2
-  else
-    break
-  end
-end
-
-set tempfile "{TempFolder}temp-domake-`Date -n`"
-if "`exists "{tempfile}"`"
-  set i 0
-  loop
-    break if ! "`exists "{tempfile}.{i}"`"
-    evaluate i += 1
-  end
-  set tempfile "{tempfile}.{i}"
-end
-
-if "{domake_files}" == ""
-  if "`exists Makefile.Mac`" != ""
-    set domake_main "Makefile.Mac"
-  else
-    set domake_main "Makefile"
-  end
-
-  if "`exists "{domake_main}".depend`" != ""
-    set domake_files "-f {domake_main} -f {domake_main}.depend"
-  else
-    set domake_files "-f {domake_main}"
-  end
-end
-
-if {domake_quiet}
-  echo >"{tempfile}"
-else
-  echo 'set echo 1' >"{tempfile}"
-end
-make {domake_files} {"Parameters"} >>"{tempfile}"
-
-"{tempfile}"
-
-Delete -i "{tempfile}"
diff --git a/tools/MakeDepend b/tools/MakeDepend
deleted file mode 100644
index 5693b27e..00000000
--- a/tools/MakeDepend
+++ /dev/null
@@ -1,17 +0,0 @@
-# MakeDepend
-
-# $Id$
-
-
-# Usage: MakeDepend fileÉ
-
-# Generate the Make dependency rules for a set of C files.
-# The rules are printed on standard output.
-
-set echo 0
-set exit 0
-
-for i in {"parameters"}
-  mrc -c -w off -make dev:stdout "{i}" ³ dev:null ¶
-  | streamedit -e '/¶"(Å)¨0.c.o¶"/ replace // "¶""¨0".c.o¶" ¶""¨0".c.x¶""'
-end
diff --git a/tools/Makefile b/tools/Makefile
index bad14c7e..da87fa99 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -19,3 +19,9 @@ include Makefile.shared
 ocamlmktop: ocamlmktop.tpl ../config/Makefile
 	sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop
 	chmod +x ocamlmktop
+
+install::
+	cp ocamlmktop $(BINDIR)
+
+clean::
+	rm -f ocamlmktop
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index b90c0c4f..b22e35d2 100644
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -21,3 +21,9 @@ OCAMLMKTOP_IMPORTS=misc.cmo config.cmo clflags.cmo ccomp.cmo
 
 ocamlmktop: $(OCAMLMKTOP)
 	$(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP)
+
+install::
+	cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE)
+
+clean::
+	rm -f ocamlmktop$(EXE)
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 32049eab..1390ac6a 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -23,7 +23,7 @@ INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
 COMPFLAGS= -warn-error A $(INCLUDES)
 LINKFLAGS=$(INCLUDES)
 
-all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib dumpobj objinfo
+all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj objinfo
 # scrapelabels addlabels
 
 .PHONY: all
@@ -35,7 +35,7 @@ opt.opt: ocamldep.opt
 
 CAMLDEP_OBJ=depend.cmo ocamldep.cmo
 CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
-  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  warnings.cmo location.cmo longident.cmo \
   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
 
 ocamldep: depend.cmi $(CAMLDEP_OBJ)
@@ -60,7 +60,7 @@ install::
 
 CSLPROF=ocamlprof.cmo
 CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
-  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  warnings.cmo location.cmo longident.cmo \
   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
 
 ocamlprof: $(CSLPROF) profiling.cmo
@@ -69,16 +69,26 @@ ocamlprof: $(CSLPROF) profiling.cmo
 ocamlcp: ocamlcp.cmo
 	$(CAMLC) $(LINKFLAGS) -o ocamlcp warnings.cmo main_args.cmo ocamlcp.cmo
 
+ocamloptp: ocamloptp.cmo
+	$(CAMLC) $(LINKFLAGS) -o ocamloptp warnings.cmo main_args.cmo \
+	         ocamloptp.cmo
+
+opt:: profiling.cmx
+
 install::
 	cp ocamlprof $(BINDIR)/ocamlprof$(EXE)
 	cp ocamlcp $(BINDIR)/ocamlcp$(EXE)
+	cp ocamloptp $(BINDIR)/ocamloptp$(EXE)
 	cp profiling.cmi profiling.cmo $(LIBDIR)
 
+installopt::
+	cp profiling.cmx profiling.o $(LIBDIR)
+
 clean::
-	rm -f ocamlprof ocamlcp
+	rm -f ocamlprof ocamlcp ocamloptp
 
 
-# To help building mixed-mode libraries (Caml + C)
+# To help building mixed-mode libraries (OCaml + C)
 
 ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo
 	$(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo \
@@ -114,19 +124,11 @@ beforedepend:: ocamlmklib.ml
 clean::
 	rm -f ocamlmklib.ml
 
-# To make custom toplevels (see Makefile/Makefile.nt)
-
-install::
-	cp ocamlmktop $(BINDIR)/   # no $(EXE) here, ocamlmktop is a script
-
-clean::
-	rm -f ocamlmktop
-
 
 # Converter olabl/ocaml 2.99 to ocaml 3
 
 OCAML299TO3= lexer299.cmo ocaml299to3.cmo
-LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo
+LIBRARY3= misc.cmo warnings.cmo location.cmo
 
 ocaml299to3: $(OCAML299TO3)
 	$(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
@@ -159,7 +161,7 @@ clean::
 # Insert labels following an interface file (upgrade 3.02 to 3.03)
 
 ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
-  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  warnings.cmo location.cmo longident.cmo \
   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
 
 addlabels: addlabels.cmo
diff --git a/tools/OCamlc-custom b/tools/OCamlc-custom
deleted file mode 100644
index c389974e..00000000
--- a/tools/OCamlc-custom
+++ /dev/null
@@ -1,10 +0,0 @@
-# OCamlc with option -custom
-# Macintosh version
-
-set echo 0
-set -e ocamlcommands "{tempfolder}"OCaml.temp."`date -n`"
-echo >"{ocamlcommands}"
-ocamlc -custom {"parameters"}
-execute "{ocamlcommands}"
-
-delete -y "{ocamlcommands}"
diff --git a/tools/Time b/tools/Time
deleted file mode 100644
index 0a826746..00000000
--- a/tools/Time
+++ /dev/null
@@ -1,10 +0,0 @@
-# Time       # Measure execution time
-# Usage: Time command argumentsÉ
-
-set echo 0
-
-set startdate `date -n`
-{parameters}
-set enddate `date -n`
-
-echo "# Time: `evaluate {enddate} - {startdate}` s" > dev:stderr
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index 15ad6f5a..c057e72c 100644
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -1,3 +1,16 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Jacques Garrigue, Kyoto University RIMS                  *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique and Kyoto University.  All rights reserved.         *)
+(*  This file is distributed under the terms of the Q Public License   *)
+(*  version 1.0.                                                       *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* $Id$ *)
 
 open StdLabels
@@ -64,7 +77,7 @@ let rec pattern_vars pat =
       pattern_vars pat1 @ pattern_vars pat2
   | Ppat_lazy pat -> pattern_vars pat
   | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
-  | Ppat_type _ ->
+  | Ppat_type _ | Ppat_unpack _ ->
       []
 
 let pattern_name pat =
@@ -311,7 +324,6 @@ let rec add_labels_class ~text ~classes ~values ~methods cl =
               add_labels_expr ~text ~classes ~values e;
               values
           | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> values
-          | Pcf_let _ -> values (* not in the grammar *)
         end)
   | Pcl_fun (_, opt, pat, cl) ->
       begin match opt with None -> ()
diff --git a/tools/checkstack.c b/tools/checkstack.c
index fc760945..9289c678 100644
--- a/tools/checkstack.c
+++ b/tools/checkstack.c
@@ -1,13 +1,12 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
 /*                                                                     */
 /*  Copyright 2002 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
+/*  under the terms of the Q Public License version 1.0.               */
 /*                                                                     */
 /***********************************************************************/
 
diff --git a/tools/cleanup-header b/tools/cleanup-header
index 6c320fb3..bc64f2e9 100644
--- a/tools/cleanup-header
+++ b/tools/cleanup-header
@@ -1,4 +1,17 @@
 #!/bin/sed -f
+
+#######################################################################
+#                                                                     #
+#                                OCaml                                #
+#                                                                     #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt         #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique.  All rights reserved.  This file is distributed    #
+#  under the terms of the Q Public License version 1.0.               #
+#                                                                     #
+#######################################################################
+
 # Remove private parts from runtime include files, before installation
 # in /usr/local/lib/ocaml/caml
 
diff --git a/tools/cvt_emit.mll b/tools/cvt_emit.mll
index 3e28ae97..eabd1baf 100644
--- a/tools/cvt_emit.mll
+++ b/tools/cvt_emit.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/tools/depend.ml b/tools/depend.ml
index 44e85702..948646a8 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,7 +75,7 @@ let add_type_declaration bv td =
   let rec add_tkind = function
     Ptype_abstract -> ()
   | Ptype_variant cstrs ->
-      List.iter (fun (c, args, _) -> List.iter (add_type bv) args) 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
@@ -118,6 +118,7 @@ let rec add_pattern bv pat =
   | Ppat_variant(_, op) -> add_opt add_pattern bv op
   | Ppat_type (li) -> add bv li
   | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack _ -> ()
 
 let rec add_expr bv exp =
   match exp.pexp_desc with
@@ -163,7 +164,7 @@ let rec add_expr bv exp =
   | Pexp_object (pat, fieldl) ->
       add_pattern bv pat; List.iter (add_class_field bv) fieldl
   | Pexp_newtype (_, e) -> add_expr bv e
-  | Pexp_pack (m, pt) -> add_package_type bv pt; add_module bv m
+  | Pexp_pack m -> add_module bv m
   | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
@@ -228,8 +229,7 @@ and add_module bv modl =
       add_module bv mod1; add_module bv mod2
   | Pmod_constraint(modl, mty) ->
       add_module bv modl; add_modtype bv mty
-  | Pmod_unpack(e, pt) ->
-      add_package_type bv pt;
+  | Pmod_unpack(e) ->
       add_expr bv e
 
 and add_structure bv item_list =
@@ -299,7 +299,6 @@ and add_class_field bv = function
   | Pcf_virt(_, _, ty, _) -> add_type bv ty
   | Pcf_meth(_, _, _, e, _) -> add_expr bv e
   | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-  | Pcf_let(_, pel, _) -> add_pat_expr_list bv pel
   | Pcf_init e -> add_expr bv e
 
 and add_class_declaration bv decl =
diff --git a/tools/depend.mli b/tools/depend.mli
index a1387061..7c6d0c01 100644
--- a/tools/depend.mli
+++ b/tools/depend.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 2a054ee6..ff7ff688 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -483,8 +483,7 @@ let print_reloc (info, pos) =
 (* Print a .cmo file *)
 
 let dump_obj filename ic =
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
+  let buffer = Misc.input_bytes ic (String.length cmo_magic_number) in
   if buffer <> cmo_magic_number then begin
     prerr_endline "Not an object file"; exit 2
   end;
@@ -503,8 +502,7 @@ let dump_obj filename ic =
 (* Read the primitive table from an executable *)
 
 let read_primitive_table ic len =
-  let p = String.create len in
-  really_input ic p 0 len;
+  let p = Misc.input_bytes ic len in
   let rec split beg cur =
     if cur >= len then []
     else if p.[cur] = '\000' then
diff --git a/tools/lexer299.mll b/tools/lexer299.mll
index 9a244721..38241af0 100644
--- a/tools/lexer299.mll
+++ b/tools/lexer299.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/tools/lexer301.mll b/tools/lexer301.mll
index daec549e..4548de57 100644
--- a/tools/lexer301.mll
+++ b/tools/lexer301.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/tools/magic b/tools/magic
index 7468066e..089f169a 100644
--- a/tools/magic
+++ b/tools/magic
@@ -1,7 +1,7 @@
 # Here are some definitions that can be added to the /usr/share/magic
 # database so that the file(1) command recognizes OCaml compiled files.
 # Contributed by Sven Luther.
-0       string  Caml1999        Objective Caml
+0       string  Caml1999        OCaml
 >8      string  X               bytecode executable
 >8      string  I               interface data (.cmi)
 >8      string  O               bytecode object data (.cmo)
diff --git a/tools/make-package-macosx b/tools/make-package-macosx
index ebdf0eba..222df822 100755
--- a/tools/make-package-macosx
+++ b/tools/make-package-macosx
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #          Damien Doligez, projet Moscova, INRIA Rocquencourt           #
 #                                                                       #
@@ -30,9 +30,9 @@ cat >Description.plist <IFPkgDescriptionDeleteWarning
           
           IFPkgDescriptionDescription
-          The Objective Caml compiler and tools
+          The OCaml compiler and tools
           IFPkgDescriptionTitle
-          Objective Caml
+          OCaml
           IFPkgDescriptionVersion
           ${VERSION}
   
@@ -46,11 +46,11 @@ cat >Info.plist <
 
         CFBundleGetInfoString
-        Objective Caml ${VERSION}
+        OCaml ${VERSION}
         CFBundleIdentifier
         fr.inria.ocaml
         CFBundleName
-        Objective Caml
+        OCaml
         CFBundleShortVersionString
         ${VERSION}
         IFMajorVersion
@@ -85,7 +85,7 @@ mkdir -p resources
 
 #                                         stop here -> |
 cat >resources/ReadMe.txt < printf "no\n"
     | l  ->
         printf "YES\n";
         printf "Primitives declared in this module:\n";
-        List.iter print_line l
+        List.iter print_line l);
+  printf "Force link: %s\n" (if cu.cu_force_link then "YES" else "no")
 
 let rec print_approx_infos ppf = function
     Value_closure(fundesc, approx) ->
@@ -122,7 +122,17 @@ let print_cmx_infos (ui, crc) =
   let pr_funs _ fns =
     List.iter (fun arity -> printf " %d" arity) fns in
   printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun;
-  printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun
+  printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun;
+  printf "Send functions:%a\n" pr_funs ui.ui_send_fun;
+  printf "Force link: %s\n" (if ui.ui_force_link then "YES" else "no")
+
+let print_cmxa_infos (lib : Cmx_format.library_infos) =
+  printf "Extra C object files:";
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  printf "\nExtra C options:";
+  List.iter print_spaced_string lib.lib_ccopts;
+  printf "\n";
+  List.iter print_cmx_infos lib.lib_units
 
 let print_cmxs_infos header =
   List.iter
@@ -207,8 +217,7 @@ let dump_obj filename =
   printf "File %s\n" filename;
   let ic = open_in_bin filename in
   let len_magic_number = String.length cmo_magic_number in
-  let magic_number = String.create len_magic_number in
-  really_input ic magic_number 0 len_magic_number;
+  let magic_number = Misc.input_bytes ic len_magic_number in
   if magic_number = cmo_magic_number then begin
     let cu_pos = input_binary_int ic in
     seek_in ic cu_pos;
@@ -234,7 +243,7 @@ let dump_obj filename =
   end else if magic_number = cmxa_magic_number then begin
     let li = (input_value ic : library_infos) in
     close_in ic;
-    List.iter print_cmx_infos li.lib_units
+    print_cmxa_infos li
   end else begin
     let pos_trailer = in_channel_length ic - len_magic_number in
     let _ = seek_in ic pos_trailer in
diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c
index 464720c2..689cdf75 100644
--- a/tools/objinfo_helper.c
+++ b/tools/objinfo_helper.c
@@ -1,11 +1,11 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*        Mehdi Dogguy, PPS laboratory, University Paris Diderot       */
 /*                                                                     */
 /*  Copyright 2010 Mehdi Dogguy.  Used and distributed as part of      */
-/*  Objective Caml by permission from the author.   This file is       */
+/*  OCaml by permission from the author.   This file is                */
 /*  distributed under the terms of the Q Public License version 1.0.   */
 /***********************************************************************/
 
diff --git a/tools/ocaml-objcopy-macosx b/tools/ocaml-objcopy-macosx
index cb2f703b..b4584a07 100755
--- a/tools/ocaml-objcopy-macosx
+++ b/tools/ocaml-objcopy-macosx
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #           Damien Doligez, projet Cristal, INRIA Rocquencourt          #
 #                                                                       #
diff --git a/tools/ocaml299to3.ml b/tools/ocaml299to3.ml
index b1dca8da..fb66c761 100644
--- a/tools/ocaml299to3.ml
+++ b/tools/ocaml299to3.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Jacques Garrigue, Kyoto University RIMS                *)
 (*                                                                     *)
@@ -124,7 +124,7 @@ let _ =
     print_endline "Usage: ocaml299to3  ...";
     print_endline "Description:";
     print_endline
-      "Convert Objective Caml 2.99 O'Labl-style labels in implementation files to";
+      "Convert OCaml 2.99 O'Labl-style labels in implementation files to";
     print_endline
       "a syntax compatible with version 3. Also `fun:' labels are replaced by `f:'.";
     print_endline "Other syntactic changes are not handled.";
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index a86ae352..9d8ed152 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -43,6 +43,7 @@ let incompatible o =
 
 module Options = Main_args.Make_bytecomp_options (struct
   let _a () = make_archive := true; option "-a" ()
+  let _absname = option "-absname"
   let _annot = option "-annot"
   let _c = option "-c"
   let _cc s = option_with_arg "-cc" s
@@ -73,6 +74,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _pp s = incompatible "-pp"
   let _principal = option "-principal"
   let _rectypes = option "-rectypes"
+  let _runtime_variant s = option_with_arg "-runtime-variant" s
   let _strict_sequence = option "-strict-sequence"
   let _thread () = option "-thread" ()
   let _vmthread () = option "-vmthread" ()
@@ -100,7 +102,7 @@ let add_profarg s =
 ;;
 
 let optlist =
-    ("-p", Arg.String add_profarg,
+    ("-P", Arg.String add_profarg,
            "[afilmt]  Profile constructs specified by argument (default fm):\n\
         \032     a  Everything\n\
         \032     f  Function calls and method calls\n\
@@ -108,6 +110,7 @@ let optlist =
         \032     l  while and for loops\n\
         \032     m  match ... with\n\
         \032     t  try ... with")
+    :: ("-p", Arg.String add_profarg, "[afilmt]  Same as option -P")
     :: Options.list
 in
 Arg.parse optlist process_file usage;
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index d92ad488..46449037 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -12,14 +12,14 @@
 
 (* $Id$ *)
 
-open Format
-open Location
 open Longident
 open Parsetree
 
 
 (* Print the dependencies *)
 
+type file_kind = ML | MLI;;
+
 let load_path = ref ([] : (string * string array) list)
 let ml_synonyms = ref [".ml"]
 let mli_synonyms = ref [".mli"]
@@ -27,6 +27,10 @@ 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
+let all_dependencies = ref false
+let one_line = ref false
+let files = ref []
 
 (* Fix path to use '/' as directory separator instead of '\'.
    Only under Windows. *)
@@ -46,17 +50,18 @@ let add_to_load_path dir =
     let contents = Sys.readdir dir in
     load_path := !load_path @ [dir, contents]
   with Sys_error msg ->
-    fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+    Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
     error_occurred := true
 
 let add_to_synonym_list synonyms suffix =
   if (String.length suffix) > 1 && suffix.[0] = '.' then
     synonyms := suffix :: !synonyms
   else begin
-    fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
+    Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
     error_occurred := true
   end
 
+(* Find file 'name' (capitalized) in search path *)
 let find_file name =
   let uname = String.uncapitalize name in
   let rec find_in_array a pos =
@@ -77,24 +82,51 @@ let rec find_file_in_list = function
   [] -> raise Not_found
 | x :: rem -> try find_file x with Not_found -> find_file_in_list rem
 
-let find_dependency modname (byt_deps, opt_deps) =
+
+let find_dependency target_kind modname (byt_deps, opt_deps) =
   try
     let candidates = List.map ((^) modname) !mli_synonyms in
     let filename = find_file_in_list candidates in
     let basename = Filename.chop_extension filename in
-    let optname =
-      if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms
-      then basename ^ ".cmx"
-      else basename ^ ".cmi" in
-    ((basename ^ ".cmi") :: byt_deps, optname :: opt_deps)
+    let cmi_file = basename ^ ".cmi" in
+    let ml_exists =
+      List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
+    let new_opt_dep =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  ->
+          cmi_file :: (if ml_exists then [ basename ^ ".cmx"] else [])
+      else
+        (* this is a make-specific hack that makes .cmx to be a 'proxy'
+           target that would force the dependency on .cmi via transitivity *)
+        if ml_exists
+        then [ basename ^ ".cmx" ]
+        else [ cmi_file ]
+    in
+    ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
   with Not_found ->
   try
+    (* "just .ml" case *)
     let candidates = List.map ((^) modname) !ml_synonyms in
     let filename = find_file_in_list candidates in
     let basename = Filename.chop_extension filename in
-    let bytename =
-      basename ^ (if !native_only then ".cmx" else ".cmo") in
-    (bytename :: byt_deps, (basename ^ ".cmx") :: opt_deps)
+    let bytenames =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [basename ^ ".cmi"]
+        | ML  -> [basename ^ ".cmi";]
+      else
+        (* again, make-specific hack *)
+        [basename ^ (if !native_only then ".cmx" else ".cmo")] in
+    let optnames =
+      if !all_dependencies
+      then match target_kind with
+        | MLI -> [basename ^ ".cmi"]
+        | ML  -> [basename ^ ".cmi"; basename ^ ".cmx"]
+      else [ basename ^ ".cmx" ]
+    in
+    (bytenames @ byt_deps, optnames @  opt_deps)
   with Not_found ->
     (byt_deps, opt_deps)
 
@@ -128,22 +160,21 @@ let print_filename s =
   end
 ;;
 
-let print_dependencies target_file deps =
-  print_filename target_file; print_string depends_on;
+let print_dependencies target_files deps =
   let rec print_items pos = function
     [] -> print_string "\n"
   | dep :: rem ->
-      if pos + 1 + String.length dep <= 77 then begin
-        print_string " "; print_filename dep;
+    if !one_line || (pos + 1 + String.length dep <= 77) then begin
+        if pos <> 0 then print_string " "; print_filename dep;
         print_items (pos + String.length dep + 1) rem
       end else begin
         print_string escaped_eol; print_filename dep;
         print_items (String.length dep + 4) rem
       end in
-  print_items (String.length target_file + 1) deps
+  print_items 0 (target_files @ [depends_on] @ deps)
 
 let print_raw_dependencies source_file deps =
-  print_filename source_file; print_string ":";
+  print_filename source_file; print_string depends_on;
   Depend.StringSet.iter
     (fun dep ->
       if (String.length dep > 0)
@@ -182,11 +213,10 @@ let remove_preprocessed inputfile =
 
 let is_ast_file ic ast_magic =
   try
-    let buffer = String.create (String.length ast_magic) in
-    really_input ic buffer 0 (String.length ast_magic);
+    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"
+      failwith "OCaml and preprocessor have incompatible versions"
     else false
   with End_of_file -> false
 
@@ -197,6 +227,7 @@ let parse_use_file ic =
   else begin
     seek_in ic 0;
     let lb = Lexing.from_channel ic in
+    Location.init lb !Location.input_name;
     Parse.use_file lb
   end
 
@@ -207,57 +238,88 @@ let parse_interface ic =
   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 *)
 
-let ml_file_dependencies source_file =
+let report_err source_file exn =
+  error_occurred := true;
+  match exn with
+    | Lexer.Error(err, range) ->
+        Format.fprintf Format.err_formatter "@[%a%a@]@."
+        Location.print_error range  Lexer.report_error err
+    | Syntaxerr.Error err ->
+        Format.fprintf Format.err_formatter "@[%a@]@."
+        Syntaxerr.report_error err
+    | Sys_error msg ->
+        Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
+    | Preprocessing_error ->
+        Format.fprintf Format.err_formatter "@[Preprocessing error on file %s@]@."
+            source_file
+    | x -> raise x
+
+let read_parse_and_extract parse_function extract_function source_file =
   Depend.free_structure_names := Depend.StringSet.empty;
-  let input_file = preprocess source_file in
-  let ic = open_in_bin input_file in
   try
-    let ast = parse_use_file ic in
-    Depend.add_use_file Depend.StringSet.empty ast;
+    let input_file = preprocess source_file in
+    let ic = open_in_bin input_file in
+    try
+      let ast = parse_function ic in
+      extract_function Depend.StringSet.empty ast;
+      !Depend.free_structure_names
+    with x ->
+      close_in ic; remove_preprocessed input_file; raise x
+  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
+  in
+  if !sort_files then
+    files := (source_file, ML, !Depend.free_structure_names) :: !files
+  else
     if !raw_dependencies then begin
-      print_raw_dependencies source_file !Depend.free_structure_names
+      print_raw_dependencies source_file extracted_deps
     end else begin
       let basename = Filename.chop_extension source_file in
-      let init_deps =
+      let byte_targets =
+        if !native_only then [] else [ basename ^ ".cmo" ] in
+      let native_targets =
+        if !all_dependencies
+        then [ basename ^ ".cmx"; basename ^ ".o" ]
+        else [ basename ^ ".cmx" ] in
+      let init_deps = if !all_dependencies then [source_file] else [] in
+      let cmi_name = basename ^ ".cmi" in
+      let init_deps, extra_targets =
         if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms
-        then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name])
-        else ([], []) in
-      let (byt_deps, opt_deps) =
-        Depend.StringSet.fold find_dependency
-                              !Depend.free_structure_names init_deps in
-      print_dependencies (basename ^ ".cmo") byt_deps;
-      print_dependencies (basename ^ ".cmx") opt_deps
-    end;
-    close_in ic; remove_preprocessed input_file
-  with x ->
-    close_in ic; remove_preprocessed input_file; raise x
+        then (cmi_name :: init_deps, cmi_name :: init_deps), []
+        else (init_deps, init_deps), ( if !all_dependencies then [cmi_name] else [] ) in
+      let (byt_deps, native_deps) =
+        Depend.StringSet.fold (find_dependency ML)
+          extracted_deps init_deps in
+      if not !native_only then print_dependencies (byte_targets @ extra_targets) byt_deps;
+      print_dependencies (native_targets @ extra_targets) native_deps;
+    end
 
 let mli_file_dependencies source_file =
-  Depend.free_structure_names := Depend.StringSet.empty;
-  let input_file = preprocess source_file in
-  let ic = open_in_bin input_file in
-  try
-    let ast = parse_interface ic in
-    Depend.add_signature Depend.StringSet.empty ast;
+  let extracted_deps = read_parse_and_extract
+    parse_interface Depend.add_signature source_file in
+  if !sort_files then
+    files := (source_file, MLI, extracted_deps) :: !files
+  else
     if !raw_dependencies then begin
-      print_raw_dependencies source_file !Depend.free_structure_names
+      print_raw_dependencies source_file extracted_deps
     end else begin
       let basename = Filename.chop_extension source_file in
       let (byt_deps, opt_deps) =
-        Depend.StringSet.fold find_dependency
-                              !Depend.free_structure_names ([], []) in
-      print_dependencies (basename ^ ".cmi") byt_deps
-    end;
-    close_in ic; remove_preprocessed input_file
-  with x ->
-    close_in ic; remove_preprocessed input_file; raise x
-
-type file_kind = ML | MLI;;
+        Depend.StringSet.fold (find_dependency MLI)
+          extracted_deps ([], []) in
+      print_dependencies [basename ^ ".cmi"] byt_deps
+    end
 
 let file_dependencies_as kind source_file =
   Location.input_name := source_file;
@@ -267,22 +329,7 @@ let file_dependencies_as kind source_file =
       | ML -> ml_file_dependencies source_file
       | MLI -> mli_file_dependencies source_file
     end
-  with x ->
-    let report_err = function
-    | Lexer.Error(err, range) ->
-        fprintf Format.err_formatter "@[%a%a@]@."
-        Location.print_error range  Lexer.report_error err
-    | Syntaxerr.Error err ->
-        fprintf Format.err_formatter "@[%a@]@."
-        Syntaxerr.report_error err
-    | Sys_error msg ->
-        fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
-    | Preprocessing_error ->
-        fprintf Format.err_formatter "@[Preprocessing error on file %s@]@."
-            source_file
-    | x -> raise x in
-    error_occurred := true;
-    report_err x
+  with x -> report_err source_file x
 
 let file_dependencies source_file =
   if List.exists (Filename.check_suffix source_file) !ml_synonyms then
@@ -291,17 +338,90 @@ let file_dependencies source_file =
     file_dependencies_as MLI source_file
   else ()
 
+let sort_files_by_dependencies files =
+  let h = Hashtbl.create 31 in
+  let worklist = ref [] in
+
+(* Init Hashtbl with all defined modules *)
+  let files = List.map (fun (file, file_kind, deps) ->
+    let modname = Filename.chop_extension (Filename.basename file) in
+    modname.[0] <- Char.uppercase modname.[0];
+    let key = (modname, file_kind) in
+    let new_deps = ref [] in
+    Hashtbl.add h key (file, new_deps);
+    worklist := key :: !worklist;
+    (modname, file_kind, deps, new_deps)
+  ) files in
+
+(* Keep only dependencies to defined modules *)
+  List.iter (fun (modname, file_kind, deps, new_deps) ->
+    let add_dep modname kind =
+      new_deps := (modname, kind) :: !new_deps;
+    in
+    Depend.StringSet.iter (fun modname ->
+      match file_kind with
+          ML -> (* ML depends both on ML and MLI *)
+            if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
+            if Hashtbl.mem h (modname, ML) then add_dep modname ML
+        | MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
+          if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+          else if Hashtbl.mem h (modname, ML) then add_dep modname ML
+    ) deps;
+    if file_kind = ML then (* add dep from .ml to .mli *)
+      if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+  ) files;
+
+(* Print and remove all files with no remaining dependency. Iterate
+   until all files have been removed (worklist is empty) or
+   no file was removed during a turn (cycle). *)
+  let printed = ref true in
+  while !printed && !worklist <> [] do
+    let files = !worklist in
+    worklist := [];
+    printed := false;
+    List.iter (fun key ->
+      let (file, deps) = Hashtbl.find h key in
+      let set = !deps in
+      deps := [];
+      List.iter (fun key ->
+        if Hashtbl.mem h key then deps := key :: !deps
+      ) set;
+      if !deps = [] then begin
+        printed := true;
+        Printf.printf "%s " file;
+        Hashtbl.remove h key;
+      end else
+        worklist := key :: !worklist
+    ) files
+  done;
+
+  if !worklist <> [] then begin
+    Format.fprintf Format.err_formatter
+      "@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
+    Hashtbl.iter (fun _ (file, deps) ->
+      Format.fprintf Format.err_formatter "\t@[%s: " file;
+      List.iter (fun (modname, kind) ->
+        Format.fprintf Format.err_formatter "%s.%s " modname
+          (if kind=ML then "ml" else "mli");
+      ) !deps;
+      Format.fprintf Format.err_formatter "@]@.";
+      Printf.printf "%s " file) h;
+  end;
+  Printf.printf "\n%!";
+  ()
+
+
 (* Entry point *)
 
 let usage = "Usage: ocamldep [options] \nOptions are:"
 
 let print_version () =
-  printf "ocamldep, version %s@." Sys.ocaml_version;
+  Format.printf "ocamldep, version %s@." Sys.ocaml_version;
   exit 0;
 ;;
 
 let print_version_num () =
-  printf "%s@." Sys.ocaml_version;
+  Format.printf "%s@." Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -310,26 +430,33 @@ let _ =
   add_to_load_path Filename.current_dir_name;
   Arg.parse [
      "-I", Arg.String add_to_load_path,
-       "  Add  to the list of include directories";
+        "  Add  to the list of include directories";
      "-impl", Arg.String (file_dependencies_as ML),
-       " Process  as a .ml file";
+           " Process  as a .ml file";
      "-intf", Arg.String (file_dependencies_as MLI),
-       " Process  as a .mli file";
+           " Process  as a .mli file";
      "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
        " Consider  as a synonym of the .ml extension";
      "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
        " Consider  as a synonym of the .mli extension";
+     "-sort", Arg.Set sort_files,
+              " Sort files according to their dependencies";
      "-modules", Arg.Set raw_dependencies,
-       " Print module dependencies in raw form (not suitable for make)";
+              " Print module dependencies in raw form (not suitable for make)";
      "-native", Arg.Set native_only,
-       "  Generate dependencies for a pure native-code project (no .cmo files)";
+             "  Generate dependencies for a pure native-code project (no .cmo files)";
+     "-all", Arg.Set all_dependencies,
+             "  Generate dependencies on all files (not accommodating for make shortcomings)";
+     "-one-line", Arg.Set one_line,
+             "  Output one line per file, regardless of the length";
      "-pp", Arg.String(fun s -> preprocessor := Some s),
-       " Pipe sources through preprocessor ";
+         " Pipe sources through preprocessor ";
      "-slash", Arg.Set force_slash,
-       "   (Windows) Use forward slash / instead of backslash \\ in file paths";
+            "   (Windows) Use forward slash / instead of backslash \\ in file paths";
      "-version", Arg.Unit print_version,
-      " Print version and exit";
+              " Print version and exit";
      "-vnum", Arg.Unit print_version_num,
-      " Print version number and exit";
+           "    Print version number and exit";
     ] file_dependencies usage;
+  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 2e2edd02..3b31201c 100644
--- a/tools/ocamlmklib.mlp
+++ b/tools/ocamlmklib.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -32,7 +32,7 @@ and c_opts = ref []      (* options to pass to mksharedlib and ocamlc -ccopt *)
 and ld_opts = ref []        (* options to pass only to the linker *)
 and ocamlc = ref (compiler_path "ocamlc")
 and ocamlopt = ref (compiler_path "ocamlopt")
-and output = ref "a"        (* Output name for Caml part of library *)
+and output = ref "a"        (* Output name for OCaml part of library *)
 and output_c = ref ""       (* Output name for C part of library *)
 and rpath = ref []          (* rpath options *)
 and verbose = ref false
@@ -152,15 +152,15 @@ Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll
 \n  -help          Print this help message and exit\
 \n  --help         Same as -help\
 \n  -h             Same as -help\
-\n  -I        Add  to the path searched for Caml object files\
+\n  -I        Add  to the path searched for OCaml object files\
 \n  -failsafe      fall back to static linking if DLL construction failed\
 \n  -ldopt    C option passed to the shared linker only\
-\n  -linkall       Build Caml archive with link-all behavior\
+\n  -linkall       Build OCaml archive with link-all behavior\
 \n  -l        Specify a dependent C library\
 \n  -L        Add  to the path searched for C libraries\
 \n  -ocamlc   Use  in place of \"ocamlc\"\
 \n  -ocamlopt  Use  in place of \"ocamlopt\"\
-\n  -o       Generated Caml library is named .cma or .cmxa\
+\n  -o       Generated OCaml library is named .cma or .cmxa\
 \n  -oc      Generated C library is named dll.so or lib.a\
 \n  -rpath    Same as -dllpath \
 \n  -R        Same as -rpath\
diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml
index 3d353a8f..0b4a8b09 100644
--- a/tools/ocamlmktop.ml
+++ b/tools/ocamlmktop.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
index 477f7387..0f44da8c 100644
--- a/tools/ocamlmktop.tpl
+++ b/tools/ocamlmktop.tpl
@@ -1,7 +1,7 @@
 #!/bin/sh
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Damien Doligez, projet Para, INRIA Rocquencourt            #
 #                                                                       #
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
new file mode 100644
index 00000000..ce251e58
--- /dev/null
+++ b/tools/ocamloptp.ml
@@ -0,0 +1,156 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: ocamlcp.ml 11890 2011-12-20 10:35:43Z frisch $ *)
+
+open Printf
+
+let compargs = ref ([] : string list)
+let profargs = ref ([] : string list)
+let toremove = ref ([] : string list)
+
+let option opt () = compargs := opt :: !compargs
+let option_with_arg opt arg =
+  compargs := (Filename.quote arg) :: opt :: !compargs
+;;
+let option_with_int opt arg =
+  compargs := (string_of_int arg) :: opt :: !compargs
+;;
+
+let make_archive = ref false;;
+let with_impl = ref false;;
+let with_intf = ref false;;
+let with_mli = ref false;;
+let with_ml = ref false;;
+
+let process_file filename =
+  if Filename.check_suffix filename ".ml" then with_ml := true;
+  if Filename.check_suffix filename ".mli" then with_mli := true;
+  compargs := (Filename.quote filename) :: !compargs
+;;
+
+let usage = "Usage: ocamloptp  \noptions are:"
+
+let incompatible o =
+  fprintf stderr "ocamloptp: profiling is incompatible with the %s option\n" o;
+  exit 2
+
+module Options = Main_args.Make_optcomp_options (struct
+  let _a () = make_archive := true; option "-a" ()
+  let _absname = option "-absname"
+  let _annot = option "-annot"
+  let _c = option "-c"
+  let _cc s = option_with_arg "-cc" s
+  let _cclib s = option_with_arg "-cclib" s
+  let _ccopt s = option_with_arg "-ccopt" s
+  let _compact = option "-compact"
+  let _config = option "-config"
+  let _for_pack s = option_with_arg "-for-pack" s
+  let _g = option "-g"
+  let _i = option "-i"
+  let _I s = option_with_arg "-I" s
+  let _impl s = with_impl := true; option_with_arg "-impl" s
+  let _inline n = option_with_int "-inline" n
+  let _intf s = with_intf := true; option_with_arg "-intf" s
+  let _intf_suffix s = option_with_arg "-intf-suffix" s
+  let _labels = option "-labels"
+  let _linkall = option "-linkall"
+  let _no_app_funct = option "-no-app-funct"
+  let _noassert = option "-noassert"
+  let _noautolink = option "-noautolink"
+  let _nodynlink = option "-nodynlink"
+  let _nolabels = option "-nolabels"
+  let _nostdlib = option "-nostdlib"
+  let _o s = option_with_arg "-o" s
+  let _output_obj = option "-output-obj"
+  let _p = option "-p"
+  let _pack = option "-pack"
+  let _pp s = incompatible "-pp"
+  let _principal = option "-principal"
+  let _rectypes = option "-rectypes"
+  let _runtime_variant s = option_with_arg "-runtime-variant" s
+  let _S = option "-S"
+  let _strict_sequence = option "-strict-sequence"
+  let _shared = option "-shared"
+  let _thread = option "-thread"
+  let _unsafe = option "-unsafe"
+  let _v = option "-v"
+  let _version = option "-version"
+  let _vnum = option "-vnum"
+  let _verbose = option "-verbose"
+  let _w = option_with_arg "-w"
+  let _warn_error = option_with_arg "-warn-error"
+  let _warn_help = option "-warn-help"
+  let _where = option "-where"
+
+  let _nopervasives = option "-nopervasives"
+  let _dparsetree = option "-dparsetree"
+  let _drawlambda = option "-drawlambda"
+  let _dlambda = option "-dlambda"
+  let _dclambda = option "-dclambda"
+  let _dcmm = option "-dcmm"
+  let _dsel = option "-dsel"
+  let _dcombine = option "-dcombine"
+  let _dlive = option "-dlive"
+  let _dspill = option "-dspill"
+  let _dsplit = option "-dsplit"
+  let _dinterf = option "-dinterf"
+  let _dprefer = option "-dprefer"
+  let _dalloc = option "-dalloc"
+  let _dreload = option "-dreload"
+  let _dscheduling = option "-dscheduling"
+  let _dlinear = option "-dlinear"
+  let _dstartup = option "-dstartup"
+
+  let anonymous = process_file
+end);;
+
+let add_profarg s =
+  profargs := (Filename.quote s) :: "-m" :: !profargs
+;;
+
+let optlist =
+    ("-P", Arg.String add_profarg,
+           "[afilmt]  Profile constructs specified by argument (default fm):\n\
+        \032     a  Everything\n\
+        \032     f  Function calls and method calls\n\
+        \032     i  if ... then ... else\n\
+        \032     l  while and for loops\n\
+        \032     m  match ... with\n\
+        \032     t  try ... with")
+    :: Options.list
+in
+Arg.parse optlist process_file usage;
+if !with_impl && !with_intf then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_impl && !with_mli then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-impl\" and .mli files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_intf && !with_ml then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-intf\" and .ml files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end;
+if !with_impl then profargs := "-impl" :: !profargs;
+if !with_intf then profargs := "-intf" :: !profargs;
+let status =
+  Sys.command
+    (Printf.sprintf "ocamlopt -pp \"ocamlprof -instrument %s\" %s %s"
+        (String.concat " " (List.rev !profargs))
+        (if !make_archive then "" else "profiling.cmx")
+        (String.concat " " (List.rev !compargs)))
+in
+exit status
+;;
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index e561f60e..b8a6b3fa 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
 (*          Ported to Caml Special Light by John Malecki               *)
@@ -287,7 +287,7 @@ and rw_exp iflag sexp =
 
   | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
   | Pexp_open (_, e) -> rewrite_exp iflag e
-  | Pexp_pack (smod, _) -> rewrite_mod iflag smod
+  | Pexp_pack (smod) -> rewrite_mod iflag smod
 
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
@@ -328,8 +328,6 @@ and rewrite_class_field iflag =
   | Pcf_meth (_, _, _, sexp, loc) ->
       if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
       else rewrite_exp iflag sexp
-  | Pcf_let(_, spat_sexp_list, _) ->
-      rewrite_patexp_list iflag spat_sexp_list
   | Pcf_init sexp ->
       rewrite_exp iflag sexp
   | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _  -> ()
@@ -362,7 +360,7 @@ and rewrite_mod iflag smod =
   | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
   | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
   | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
-  | Pmod_unpack(sexp, _) -> rewrite_exp iflag sexp
+  | Pmod_unpack(sexp) -> rewrite_exp iflag sexp
 
 and rewrite_str_item iflag item =
   match item.pstr_desc with
diff --git a/tools/ocamlsize b/tools/ocamlsize
index 659543d5..7b419ceb 100755
--- a/tools/ocamlsize
+++ b/tools/ocamlsize
@@ -1,5 +1,17 @@
 #!/usr/bin/perl
 
+#######################################################################
+#                                                                     #
+#                                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.               #
+#                                                                     #
+#######################################################################
+
 foreach $f (@ARGV) {
     open(FILE, $f) || die("Cannot open $f");
     seek(FILE, -16, 2);
diff --git a/tools/primreq.ml b/tools/primreq.ml
index dcace11b..c1764f5d 100644
--- a/tools/primreq.ml
+++ b/tools/primreq.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/tools/profiling.ml b/tools/profiling.ml
index 9c6d9dd0..06c97610 100644
--- a/tools/profiling.ml
+++ b/tools/profiling.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
 (*   Ported to Caml Special Light by John Malecki and Xavier Leroy     *)
diff --git a/tools/profiling.mli b/tools/profiling.mli
index ca8486f4..61be2be7 100644
--- a/tools/profiling.mli
+++ b/tools/profiling.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
-(*   Ported to Objective Caml by John Malecki and Xavier Leroy         *)
+(*   Ported to OCaml by John Malecki and Xavier Leroy                  *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml
index dc43e97b..3d8ab032 100644
--- a/tools/scrapelabels.ml
+++ b/tools/scrapelabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Jacques Garrigue, Kyoto University RIMS                *)
 (*                                                                     *)
diff --git a/tools/setignore b/tools/setignore
new file mode 100755
index 00000000..708ed26c
--- /dev/null
+++ b/tools/setignore
@@ -0,0 +1,39 @@
+#!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 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.                #
+#                                                                       #
+#########################################################################
+
+(
+  cat < Hashtbl.add h n ()) Runtimedef.builtin_exceptions;
+  Hashtbl.mem h
+
 let to_keep = ref StringSet.empty
 
+let negate = Sys.argv.(3) = "-v"
+
+let keep = 
+  if negate then fun name -> is_exn name || not (StringSet.mem name !to_keep)
+  else fun name -> is_exn name || (StringSet.mem name !to_keep)
+
 let expunge_map tbl =
-  Symtable.filter_global_map
-    (fun id -> StringSet.mem (Ident.name id) !to_keep)
-    tbl
+  Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl
 
 let expunge_crcs tbl =
-  List.filter (fun (unit, crc) -> StringSet.mem unit !to_keep) tbl
+  List.filter (fun (unit, crc) -> keep unit) tbl
 
 let main () =
   let input_name = Sys.argv.(1) in
   let output_name = Sys.argv.(2) in
-  Array.iter
-    (fun exn -> to_keep := StringSet.add exn !to_keep)
-    Runtimedef.builtin_exceptions;
-  for i = 3 to Array.length Sys.argv - 1 do
+  for i = (if negate then 4 else 3) to Array.length Sys.argv - 1 do
     to_keep := StringSet.add (String.capitalize Sys.argv.(i)) !to_keep
   done;
   let ic = open_in_bin input_name in
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 32770040..2bf72f19 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -180,7 +180,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
           find_printer env ty obj
         with Not_found ->
           match (Ctype.repr ty).desc with
-          | Tvar ->
+          | Tvar _ | Tunivar _ ->
               Oval_stuff ""
           | Tarrow(_, ty1, ty2, _) ->
               Oval_stuff ""
@@ -247,16 +247,25 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                       if O.is_block obj
                       then Cstr_block(O.tag obj)
                       else Cstr_constant(O.obj obj) in
-                    let (constr_name, constr_args) =
+                    let (constr_name, constr_args,ret_type) =
                       Datarepr.find_constr_by_tag tag constr_list in
+		    let type_params = 
+		      match ret_type with
+			Some t -> 
+			  begin match (Ctype.repr t).desc with 
+			    Tconstr (_,params,_) ->
+			      params
+			  | _ -> assert false end
+		      | None -> decl.type_params
+		    in
                     let ty_args =
                       List.map
                         (function ty ->
-                           try Ctype.apply env decl.type_params ty ty_list with
+                           try Ctype.apply env type_params ty ty_list with
                              Ctype.Cannot_apply -> abstract_type)
                         constr_args in
                     tree_of_constr_with_args (tree_of_constr env path)
-                                           constr_name 0 depth obj ty_args
+                                           constr_name 0 depth obj ty_args		    
                 | {type_kind = Type_record(lbl_list, rep)} ->
                     begin match check_depth depth obj ty with
                       Some x -> x
@@ -318,8 +327,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
               fatal_error "Printval.outval_of_value"
           | Tpoly (ty, _) ->
               tree_of_val (depth - 1) obj ty
-          | Tunivar ->
-              Oval_stuff ""
           | Tpackage _ ->
               Oval_stuff ""
         end
@@ -347,7 +354,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
         let cstr = Env.lookup_constructor lid env in
         let path =
           match cstr.cstr_tag with
-            Cstr_exception p -> p | _ -> raise Not_found in
+            Cstr_exception (p, _) -> p | _ -> raise Not_found in
         (* Make sure this is the right exception and not an homonym,
            by evaluating the exception found and comparing with the
            identifier contained in the exception bucket *)
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 898588b2..6522cccd 100644
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)
diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
index b586bae1..8655ef96 100644
--- a/toplevel/opttopdirs.ml
+++ b/toplevel/opttopdirs.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -112,7 +112,7 @@ let match_printer_type ppf desc typename =
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env
     (Ctype.newconstr printer_type [ty_arg])
-    (Ctype.instance desc.val_type);
+    (Ctype.instance_def desc.val_type);
   Ctype.end_def();
   Ctype.generalize ty_arg;
   ty_arg
diff --git a/toplevel/opttopdirs.mli b/toplevel/opttopdirs.mli
index 800c6cf7..9a8573e5 100644
--- a/toplevel/opttopdirs.mli
+++ b/toplevel/opttopdirs.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index ee6b5a0e..8d83908d 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -225,7 +225,6 @@ let execute_phrase print_outcome ppf phr =
       incr phrase_seqid;
       phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
       Compilenv.reset ?packname:None !phrase_name;
-      let _ = Unused_var.warn ppf sstr in
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
       in
@@ -301,8 +300,15 @@ let use_print_results = ref true
 
 let use_file ppf name =
   try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
+    let (filename, ic, must_close) =
+      if name = "" then
+        ("(stdin)", stdin, false)
+      else begin
+        let filename = find_in_path !Config.load_path name in
+        let ic = open_in_bin filename in
+        (filename, ic, true)
+      end
+    in
     let lb = Lexing.from_channel ic in
     Location.init lb filename;
     (* Skip initial #! line if any *)
@@ -320,7 +326,7 @@ let use_file ppf name =
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
         | x -> Opterrors.report_error ppf x; false) in
-    close_in ic;
+    if must_close then close_in ic;
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
@@ -357,6 +363,7 @@ let refill_lexbuf buffer len =
     let prompt =
       if !Clflags.noprompt then ""
       else if !first_line then "# "
+      else if !Clflags.nopromptcont then ""
       else if Lexer.in_comment () then "* "
       else "  "
     in
@@ -409,10 +416,11 @@ let initialize_toplevel_env () =
 exception PPerror
 
 let loop ppf =
-  fprintf ppf "        Objective Caml version %s - native toplevel@.@." Config.version;
+  fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
-  Location.input_name := "";
+  Location.init lb "//toplevel//";
+  Location.input_name := "//toplevel//";
   Location.input_lexbuf := Some lb;
   Sys.catch_break true;
   load_ocamlinit ppf;
diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
index 78e45f0b..cdd32de1 100644
--- a/toplevel/opttoploop.mli
+++ b/toplevel/opttoploop.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index bd27abb7..ac32a5c1 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -49,7 +49,7 @@ let file_argument name =
     end
 
 let print_version () =
-  Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version;
+  Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -62,6 +62,7 @@ module Options = Main_args.Make_opttop_options (struct
   let set r () = r := true
   let clear r () = r := false
 
+  let _absname = set Location.absname
   let _compact = clear optimize_for_speed
   let _I dir =
     let dir = Misc.expand_directory Config.standard_library dir in
@@ -73,11 +74,13 @@ module Options = Main_args.Make_opttop_options (struct
   let _noassert = set noassert
   let _nolabels = set classic
   let _noprompt = set noprompt
+  let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _principal = set principal
   let _rectypes = set recursive_types
   let _strict_sequence = set strict_sequence
   let _S = set keep_asm_file
+  let _stdin () = file_argument ""
   let _unsafe = set fast
   let _version () = print_version ()
   let _vnum () = print_version_num ()
diff --git a/toplevel/opttopmain.mli b/toplevel/opttopmain.mli
index 197f88bb..61747d89 100644
--- a/toplevel/opttopmain.mli
+++ b/toplevel/opttopmain.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/opttopstart.ml b/toplevel/opttopstart.ml
index 3e3fe58b..db279940 100644
--- a/toplevel/opttopstart.ml
+++ b/toplevel/opttopstart.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 6516a387..bca47098 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -85,19 +85,43 @@ let load_compunit ic filename ppf compunit =
     raise Load_failed
   end
 
-let load_file ppf name =
+let rec load_file recursive ppf name =
+  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 ->
+      let ic = open_in_bin filename in
+      try
+        let success = really_load_file recursive ppf name filename ic in
+        close_in ic;
+        success
+      with exn ->
+        close_in ic;
+        raise exn
+
+and really_load_file recursive ppf name filename ic =
+  let ic = open_in_bin filename in
+  let buffer = Misc.input_bytes ic (String.length Config.cmo_magic_number) in
   try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
-    let buffer = String.create (String.length Config.cmo_magic_number) in
-    really_input ic buffer 0 (String.length Config.cmo_magic_number);
-    let success = try
-      if buffer = Config.cmo_magic_number then begin
-        let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
-        seek_in ic compunit_pos;
-        load_compunit ic filename ppf (input_value ic : compilation_unit);
-        true
-      end else
+    if buffer = Config.cmo_magic_number then begin
+      let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
+      seek_in ic compunit_pos;
+      let cu : compilation_unit = input_value ic in
+      if recursive then
+        List.iter
+          (function
+            | (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
+                | None -> ()
+                | Some file -> if not (load_file recursive ppf file) then raise Load_failed
+                end
+            | _ -> ()
+          )
+          cu.cu_reloc;
+      load_compunit ic filename ppf cu;
+      true
+    end else
       if buffer = Config.cma_magic_number then begin
         let toc_pos = input_binary_int ic in  (* Go to table of contents *)
         seek_in ic toc_pos;
@@ -118,15 +142,18 @@ let load_file ppf name =
         fprintf ppf "File %s is not a bytecode object file.@." name;
         false
       end
-    with Load_failed -> false in
-    close_in ic;
-    success
-  with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
+  with Load_failed -> false
 
-let dir_load ppf name = ignore (load_file ppf name)
+let dir_load ppf name = ignore (load_file false ppf name)
 
 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 load_file = load_file false
+
 (* Load commands from a file *)
 
 let dir_use ppf name = ignore(Toploop.use_file ppf name)
@@ -150,7 +177,7 @@ let match_printer_type ppf desc typename =
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env
     (Ctype.newconstr printer_type [ty_arg])
-    (Ctype.instance desc.val_type);
+    (Ctype.instance_def desc.val_type);
   Ctype.end_def();
   Ctype.generalize ty_arg;
   ty_arg
diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli
index 36af2211..11aa9b85 100644
--- a/toplevel/topdirs.mli
+++ b/toplevel/topdirs.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/toplevellib.mllib b/toplevel/toplevellib.mllib
index a5e8b03f..eb459a90 100644
--- a/toplevel/toplevellib.mllib
+++ b/toplevel/toplevellib.mllib
@@ -1,7 +1,7 @@
 Myocamlbuild_config
 Misc Tbl Config Clflags Terminfo Ccomp Warnings Consistbl
 
-Linenum Location Longident Syntaxerr Parser
+Location Longident Syntaxerr Parser
 Lexer Parse Printast
 
 Unused_var Ident Path Primitive Types
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 250a27b5..6a83bcc9 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -217,7 +217,6 @@ let execute_phrase print_outcome ppf phr =
   match phr with
   | Ptop_def sstr ->
       let oldenv = !toplevel_env in
-      let _ = Unused_var.warn ppf sstr in
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
       in
@@ -284,14 +283,21 @@ let protect r newval body =
     r := oldval;
     raise x
 
-(* Read and execute commands from a file *)
+(* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
 
 let use_file ppf name =
   try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
+    let (filename, ic, must_close) =
+      if name = "" then
+        ("(stdin)", stdin, false)
+      else begin
+        let filename = find_in_path !Config.load_path name in
+        let ic = open_in_bin filename in
+        (filename, ic, true)
+      end
+    in
     let lb = Lexing.from_channel ic in
     Location.init lb filename;
     (* Skip initial #! line if any *)
@@ -309,7 +315,7 @@ let use_file ppf name =
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
         | x -> Errors.report_error ppf x; false) in
-    close_in ic;
+    if must_close then close_in ic;
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
@@ -346,6 +352,7 @@ let refill_lexbuf buffer len =
     let prompt =
       if !Clflags.noprompt then ""
       else if !first_line then "# "
+      else if !Clflags.nopromptcont then ""
       else if Lexer.in_comment () then "* "
       else "  "
     in
@@ -400,10 +407,11 @@ let initialize_toplevel_env () =
 exception PPerror
 
 let loop ppf =
-  fprintf ppf "        Objective Caml version %s@.@." Config.version;
+  fprintf ppf "        OCaml version %s@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
-  Location.input_name := "";
+  Location.init lb "//toplevel//";
+  Location.input_name := "//toplevel//";
   Location.input_lexbuf := Some lb;
   Sys.catch_break true;
   load_ocamlinit ppf;
@@ -415,6 +423,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;
+      Env.reset_missing_cmis ();
       ignore(execute_phrase true ppf phr)
     with
     | End_of_file -> exit 0
@@ -423,7 +432,7 @@ let loop ppf =
     | x -> Errors.report_error ppf x; Btype.backtrack snap
   done
 
-(* Execute a script *)
+(* Execute a script.  If [name] is "", read the script from stdin. *)
 
 let run_script ppf name args =
   let len = Array.length args in
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index 35eb5dbf..e9afb5a0 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 4bf9922a..27b2ca28 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,7 +14,8 @@
 
 open Clflags
 
-let usage = "Usage: ocaml   [script-file]\noptions are:"
+let usage = "Usage: ocaml   [script-file [arguments]]\n\
+             options are:"
 
 let preload_objects = ref []
 
@@ -31,6 +32,7 @@ let prepare ppf =
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false
 
+(* If [name] is "", then the "file" is stdin treated as a script file. *)
 let file_argument name =
   let ppf = Format.err_formatter in
   if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
@@ -46,7 +48,7 @@ let file_argument name =
     end
 
 let print_version () =
-  Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version;
+  Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -59,6 +61,7 @@ module Options = Main_args.Make_bytetop_options (struct
   let set r () = r := true
   let clear r () = r := false
 
+  let _absname = set Location.absname
   let _I dir =
     let dir = Misc.expand_directory Config.standard_library dir in
     include_dirs := dir :: !include_dirs
@@ -68,9 +71,11 @@ module Options = Main_args.Make_bytetop_options (struct
   let _noassert = set noassert
   let _nolabels = set classic
   let _noprompt = set noprompt
+  let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _principal = set principal
   let _rectypes = set recursive_types
+  let _stdin () = file_argument ""
   let _strict_sequence = set strict_sequence
   let _unsafe = set fast
   let _version () = print_version ()
diff --git a/toplevel/topmain.mli b/toplevel/topmain.mli
index 197f88bb..61747d89 100644
--- a/toplevel/topmain.mli
+++ b/toplevel/topmain.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/topstart.ml b/toplevel/topstart.ml
index 570e2f20..823b4c81 100644
--- a/toplevel/topstart.ml
+++ b/toplevel/topstart.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index fad92d98..104f39fe 100644
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/toplevel/trace.mli b/toplevel/trace.mli
index d708361c..0675dd1b 100644
--- a/toplevel/trace.mli
+++ b/toplevel/trace.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/annot.mli b/typing/annot.mli
index 92b2f6ec..93443819 100644
--- a/typing/annot.mli
+++ b/typing/annot.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/btype.ml b/typing/btype.ml
index e57e760f..c9bdbf04 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -16,6 +16,17 @@
 
 open Types
 
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
 (**** Type level management ****)
 
 let generic_level = 100000000
@@ -30,9 +41,9 @@ let pivot_level = 2 * lowest_level - 1
 let new_id = ref (-1)
 
 let newty2 level desc  =
-  incr new_id; { desc = desc; level = level; id = !new_id }
+  incr new_id; { desc; level; id = !new_id }
 let newgenty desc      = newty2 generic_level desc
-let newgenvar ()       = newgenty Tvar
+let newgenvar ?name () = newgenty (Tvar name)
 (*
 let newmarkedvar level =
   incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
@@ -41,6 +52,11 @@ let newmarkedgenvar () =
   { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
 *)
 
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+
 (**** Representative of a type ****)
 
 let rec field_kind_repr =
@@ -134,7 +150,7 @@ let proxy ty =
       let rec proxy_obj ty =
         match ty.desc with
           Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
-        | Tvar | Tunivar | Tconstr _ -> ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
         | Tnil -> ty0
         | _ -> assert false
       in proxy_obj ty
@@ -175,13 +191,13 @@ let rec iter_row f row =
     row.row_fields;
   match (repr row.row_more).desc with
     Tvariant row -> iter_row f row
-  | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
       Misc.may (fun (_,l) -> List.iter f l) row.row_name
   | _ -> assert false
 
 let iter_type_expr f ty =
   match ty.desc with
-    Tvar                -> ()
+    Tvar _              -> ()
   | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
   | Ttuple l            -> List.iter f l
   | Tconstr (_, l, _)   -> List.iter f l
@@ -193,7 +209,7 @@ let iter_type_expr f ty =
   | Tnil                -> ()
   | Tlink ty            -> f ty
   | Tsubst ty           -> f ty
-  | Tunivar             -> ()
+  | Tunivar _           -> ()
   | Tpoly (ty, tyl)     -> f ty; List.iter f tyl
   | Tpackage (_, _, l)  -> List.iter f l
 
@@ -234,13 +250,13 @@ let copy_commu c =
    encoding during substitution *)
 let rec norm_univar ty =
   match ty.desc with
-    Tunivar | Tsubst _ -> ty
+    Tunivar _ | Tsubst _ -> ty
   | Tlink ty           -> norm_univar ty
   | Ttuple (ty :: _)   -> norm_univar ty
   | _                  -> assert false
 
 let rec copy_type_desc f = function
-    Tvar                -> Tvar
+    Tvar _              -> Tvar None (* forget the name *)
   | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
   | Ttuple l            -> Ttuple (List.map f l)
   | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
@@ -253,7 +269,7 @@ let rec copy_type_desc f = function
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
   | Tsubst ty           -> assert false
-  | Tunivar             -> Tunivar
+  | Tunivar _ as ty     -> ty (* keep the name *)
   | Tpoly (ty, tyl)     ->
       let tyl = List.map (fun x -> norm_univar (f x)) tyl in
       Tpoly (f ty, tyl)
@@ -314,7 +330,11 @@ let unmark_type_decl decl =
   begin match decl.type_kind with
     Type_abstract -> ()
   | Type_variant cstrs ->
-      List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
+      List.iter 
+	(fun (c, tl, ret_type_opt) -> 
+	  List.iter unmark_type tl;
+	  Misc.may unmark_type ret_type_opt)
+	cstrs
   | Type_record(lbls, rep) ->
       List.iter (fun (c, mut, t) -> unmark_type t) lbls
   end;
@@ -436,15 +456,17 @@ type change =
   | Ckind of field_kind option ref * field_kind option
   | Ccommu of commutable ref * commutable
   | Cuniv of type_expr option ref * type_expr option
+  | Ctypeset of TypeSet.t ref * TypeSet.t
 
 let undo_change = function
-    Ctype  (ty, desc)  -> ty.desc <- desc
+    Ctype  (ty, desc) -> ty.desc <- desc
   | Clevel (ty, level) -> ty.level <- level
   | Cname  (r, v) -> r := v
   | Crow   (r, v) -> r := v
   | Ckind  (r, v) -> r := v
   | Ccommu (r, v) -> r := v
   | Cuniv  (r, v) -> r := v
+  | Ctypeset (r, v) -> r := v
 
 type changes =
     Change of change * changes ref
@@ -465,7 +487,22 @@ let log_change ch =
 
 let log_type ty =
   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
-let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  ty.desc <- Tlink ty';
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
+      | None, Some _ ->  ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
+      | None, None   ->  ()
+      end
+  | _ -> ()
   (* ; assert (check_memorized_abbrevs ()) *)
   (*  ; check_expans [] ty' *)
 let set_level ty level =
@@ -481,6 +518,8 @@ let set_kind rk k =
   log_change (Ckind (rk, !rk)); rk := Some k
 let set_commu rc c =
   log_change (Ccommu (rc, !rc)); rc := c
+let set_typeset rs s =
+  log_change (Ctypeset (rs, !rs)); rs := s
 
 let snapshot () =
   let old = !last_snapshot in
diff --git a/typing/btype.mli b/typing/btype.mli
index 4ea5e3b4..e2e4c9d6 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -17,13 +17,21 @@
 open Asttypes
 open Types
 
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
 val generic_level: int
 
 val newty2: int -> type_desc -> type_expr
         (* Create a type *)
 val newgenty: type_desc -> type_expr
         (* Create a generic type *)
-val newgenvar: unit -> type_expr
+val newgenvar: ?name:string -> unit -> type_expr
         (* Return a fresh generic variable *)
 
 (* Use Tsubst instead
@@ -33,6 +41,9 @@ val newmarkedgenvar: unit -> type_expr
         (* Return a fresh marked generic variable *)
 *)
 
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+
 val repr: type_expr -> type_expr
         (* Return the canonical representative of a type. *)
 
@@ -43,6 +54,8 @@ val field_kind_repr: field_kind -> field_kind
 val commu_repr: commutable -> commutable
         (* Return the canonical representative of a commutation lock *)
 
+(**** polymorphic variants ****)
+
 val row_repr: row_desc -> row_desc
         (* Return the canonical representative of a row description *)
 val row_field_repr: row_field -> row_field
@@ -150,6 +163,10 @@ val set_row_field: row_field option ref -> row_field -> unit
 val set_univar: type_expr option ref -> type_expr -> unit
 val set_kind: field_kind option ref -> field_kind -> unit
 val set_commu: commutable ref -> commutable -> unit
+val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
         (* Set references, logging the old value *)
 val log_type: type_expr -> unit
         (* Log the old value of a type, before modifying it by hand *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 356260b5..86d744ac 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -95,6 +95,9 @@ exception Cannot_apply
 
 exception Recursive_abbrev
 
+(* GADT: recursive abbrevs can appear as a result of local constraints *)
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
+
 (**** Type level management ****)
 
 let current_level = ref 0
@@ -102,6 +105,7 @@ let nongen_level = ref 0
 let global_level = ref 1
 let saved_level = ref []
 
+let get_current_level () = !current_level
 let init_def level = current_level := level; nongen_level := level
 let begin_def () =
   saved_level := (!current_level, !nongen_level) :: !saved_level;
@@ -136,9 +140,18 @@ let is_object_type path =
 
 (**** Abbreviations without parameters ****)
 (* Shall reset after generalizing *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
 let simple_abbrevs = ref Mnil
+
 let proper_abbrevs path tl abbrev =
-  if !Clflags.principal || tl <> [] || is_object_type path then abbrev
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
   else simple_abbrevs
 
 (**** Some type creators ****)
@@ -149,9 +162,9 @@ let newty2             = Btype.newty2
 let newty desc         = newty2 !current_level desc
 let new_global_ty desc = newty2 !global_level desc
 
-let newvar ()          = newty2 !current_level Tvar
-let newvar2 level      = newty2 level Tvar
-let new_global_var ()  = newty2 !global_level Tvar
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
 
 let newobj fields      = newty (Tobject (fields, ref None))
 
@@ -173,6 +186,48 @@ module TypePairs =
     let hash (t, t') = t.id + 93 * t'.id
  end)
 
+
+(**** unification mode ****)
+
+type unification_mode = 
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+let umode = ref Expression
+let generate_equations = ref false
+
+let set_mode mode ?(generate = (mode = Pattern)) f = 
+  let old_unification_mode = !umode
+  and old_gen = !generate_equations in
+  try
+    umode := mode;
+    generate_equations := generate;
+    let ret = f () in
+    umode := old_unification_mode;
+    generate_equations := old_gen;
+    ret
+  with e ->
+    umode := old_unification_mode;
+    generate_equations := old_gen;
+    raise e
+
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p = 
+    try ignore (Env.find_type p Env.initial); true
+    with Not_found -> false
+        
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ -> true
+  | Type_abstract -> false
+
+
                   (**********************************************)
                   (*  Miscellaneous operations on object types  *)
                   (**********************************************)
@@ -236,10 +291,13 @@ let rec object_row ty =
 
 let opened_object ty =
   match (object_row ty).desc with
-  | Tvar               -> true
-  | Tunivar            -> true
-  | Tconstr _          -> true
-  | _                  -> false
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
 
 (**** Close an object ****)
 
@@ -247,7 +305,7 @@ let close_object ty =
   let rec close ty =
     let ty = repr ty in
     match ty.desc with
-      Tvar ->
+      Tvar _ ->
         link_type ty (newty2 ty.level Tnil)
     | Tfield(_, _, _, ty') -> close ty'
     | _                    -> assert false
@@ -263,7 +321,7 @@ let row_variable ty =
     let ty = repr ty in
     match ty.desc with
       Tfield (_, _, _, ty) -> find ty
-    | Tvar                 -> ty
+    | Tvar _               -> ty
     | _                    -> assert false
   in
   match (repr ty).desc with
@@ -368,7 +426,7 @@ let rec closed_schema_rec ty =
     let level = ty.level in
     ty.level <- pivot_level - level;
     match ty.desc with
-      Tvar when level <> generic_level ->
+      Tvar _ when level <> generic_level ->
         raise Non_closed
     | Tfield(_, kind, t1, t2) ->
         if field_kind_repr kind = Fpresent then
@@ -402,11 +460,11 @@ let rec free_vars_rec real ty =
   if ty.level >= lowest_level then begin
     ty.level <- pivot_level - ty.level;
     begin match ty.desc, !really_closed with
-      Tvar, _ ->
+      Tvar _, _ ->
         free_variables := (ty, real) :: !free_variables
     | Tconstr (path, tl, _), Some env ->
         begin try
-          let (_, body) = Env.find_type_expansion path env in
+          let (_, body, _) = Env.find_type_expansion path env in
           if (repr body).level <> generic_level then
             free_variables := (ty, real) :: !free_variables
         with Not_found -> ()
@@ -463,7 +521,13 @@ let closed_type_decl decl =
       Type_abstract ->
         ()
     | Type_variant v ->
-        List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
+        List.iter 
+          (fun (_, tyl,ret_type_opt) ->
+            match ret_type_opt with
+            | Some _ -> ()
+            | None ->
+                List.iter closed_type tyl)
+          v 
     | Type_record(r, rep) ->
         List.iter (fun (_, _, ty) -> closed_type ty) r
     end;
@@ -567,14 +631,16 @@ let iterative_generalization min_level tyl =
 let rec generalize_structure var_level ty =
   let ty = repr ty in
   if ty.level <> generic_level then begin
-    if ty.desc = Tvar && ty.level > var_level then
+    if is_Tvar ty && ty.level > var_level then
       set_level ty var_level
-    else if ty.level > !current_level then begin
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
       set_level ty generic_level;
-      begin match ty.desc with
-        Tconstr (_, _, abbrev) -> abbrev := Mnil
-      | _ -> ()
-      end;
       iter_type_expr (generalize_structure var_level) ty
     end
   end
@@ -583,19 +649,27 @@ let generalize_structure var_level ty =
   simple_abbrevs := Mnil;
   generalize_structure var_level ty
 
-(* let generalize_expansive ty = generalize_structure !nongen_level ty *)
-let generalize_global ty = generalize_structure !global_level ty
-let generalize_structure ty = generalize_structure !current_level ty
-
 (* Generalize the spine of a function, if the level >= !current_level *)
 
 let rec generalize_spine ty =
   let ty = repr ty in
   if ty.level < !current_level || ty.level = generic_level then () else
   match ty.desc with
-    Tarrow (_, _, ty', _) | Tpoly (ty', _) ->
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
       set_level ty generic_level;
       generalize_spine ty'
+  | Ttuple tyl
+  | Tpackage (_, _, tyl) ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
   | _ -> ()
 
 let forward_try_expand_once = (* Forward declaration *)
@@ -613,29 +687,47 @@ let forward_try_expand_once = (* Forward declaration *)
       module M = struct type t let _ = (x : t list ref) end
     (without this constraint, the type system would actually be unsound.)
 *)
+let get_level env p = 
+  try
+    match (Env.find_type p env).type_newtype_level with
+      | None -> Path.binding_time p
+      | Some (x, _) -> x
+  with 
+    | _ -> 
+      (* no newtypes in predef *)
+      Path.binding_time p
+
 let rec update_level env level ty =
   let ty = repr ty in
   if ty.level > level then begin
-    begin match ty.desc with
-      Tconstr(p, tl, abbrev)  when level < Path.binding_time p ->
+    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 -> ()
+    end;
+    match ty.desc with
+      Tconstr(p, tl, abbrev) when level < get_level env p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
+          (* if is_newtype env p then raise Cannot_expand; *)
           link_type ty (!forward_try_expand_once env ty);
           update_level env level ty
         with Cannot_expand ->
           (* +++ Levels should be restored... *)
-          raise (Unify [(ty, newvar2 level)])
+          (* Format.printf "update_level: %i < %i@." level (get_level env p); *)
+          if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
+          iter_type_expr (update_level env level) ty
         end
-    | Tpackage (p, _, _) when level < Path.binding_time p ->
+    | Tpackage (p, _, _) when level < get_level env p ->
         raise (Unify [(ty, newvar2 level)])
     | Tobject(_, ({contents=Some(p, tl)} as nm))
-      when level < Path.binding_time p ->
+      when level < get_level env p ->
         set_name nm None;
         update_level env level ty
     | Tvariant row ->
         let row = row_repr row in
         begin match row.row_name with
-        | Some (p, tl) when level < Path.binding_time p ->
+        | Some (p, tl) when level < get_level env p ->
             log_type ty;
             ty.desc <- Tvariant {row with row_name = None}
         | _ -> ()
@@ -648,11 +740,13 @@ let rec update_level env level ty =
         set_level ty level;
         (* XXX what about abbreviations in Tconstr ? *)
         iter_type_expr (update_level env level) ty
-    end
   end
 
 (* Generalize and lower levels of contravariant branches simultaneously *)
 
+let generalize_contravariant env =
+  if !Clflags.principal then generalize_structure else update_level env
+
 let rec generalize_expansive env var_level ty =
   let ty = repr ty in
   if ty.level <> generic_level then begin
@@ -666,13 +760,13 @@ let rec generalize_expansive env var_level ty =
           abbrev := Mnil;
           List.iter2
             (fun (co,cn,ct) t ->
-              if ct then update_level env var_level t
+              if ct then generalize_contravariant env var_level t
               else generalize_expansive env var_level t)
             variance tyl
       | Tpackage (_, _, tyl) ->
-          List.iter (update_level env var_level) tyl
+          List.iter (generalize_contravariant env var_level) tyl
       | Tarrow (_, t1, t2, _) ->
-          update_level env var_level t1;
+          generalize_contravariant env var_level t1;
           generalize_expansive env var_level t2
       | _ ->
           iter_type_expr (generalize_expansive env var_level) ty
@@ -683,8 +777,11 @@ let generalize_expansive env ty =
   simple_abbrevs := Mnil;
   try
     generalize_expansive env !nongen_level ty
-  with Unify [_, ty'] ->
-    raise (Unify [ty, ty'])
+  with Unify ([_, ty'] as tr) ->
+    raise (Unify ((ty, ty') :: tr))
+
+let generalize_global ty = generalize_structure !global_level ty
+let generalize_structure ty = generalize_structure !current_level ty
 
 (* Correct the levels of type [ty]. *)
 let correct_levels ty =
@@ -738,6 +835,47 @@ let limited_generalize ty0 ty =
     graph
 
 
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
                               (*******************)
                               (*  Instantiation  *)
                               (*******************)
@@ -767,15 +905,38 @@ let rec find_repr p1 =
 let abbreviations = ref (ref Mnil)
   (* Abbreviation memorized. *)
 
-let rec copy ty =
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?env ?partial ty =
+  let copy = copy ?env ?partial in
   let ty = repr ty in
   match ty.desc with
     Tsubst ty -> ty
   | _ ->
-    if ty.level <> generic_level then ty else
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
     let desc = ty.desc in
     save_desc ty desc;
     let t = newvar() in          (* Stub *)
+    begin match env with
+      Some env when Env.has_local_constraints env ->
+        begin match Env.gadt_instance_level env ty with
+          Some lv -> Env.add_gadt_instances env lv [t]
+        | None -> ()
+        end
+    | _ -> ()
+    end;
     ty.desc <- Tsubst t;
     t.desc <-
       begin match desc with
@@ -815,10 +976,10 @@ let rec copy ty =
               let more' =
                 match more.desc with
                   Tsubst ty -> ty
-                | Tconstr _ ->
+                | Tconstr _ | Tnil ->
                     if keep then save_desc more more.desc;
                     copy more
-                | Tvar | Tunivar ->
+                | Tvar _ | Tunivar _ ->
                     save_desc more more.desc;
                     if keep then more else newty more.desc
                 |  _ -> assert false
@@ -836,25 +997,86 @@ let rec copy ty =
               dup_kind r;
               copy_type_desc copy desc
           end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
       | _ -> copy_type_desc copy desc
       end;
     t
 
 (**** Variants of instantiations ****)
 
-let instance sch =
-  let ty = copy sch in
+let gadt_env env =
+  if Env.has_local_constraints env
+  then Some env
+  else None
+
+let instance ?partial env sch =
+  let env = gadt_env env in
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  let ty = copy ?env ?partial sch in
   cleanup_types ();
   ty
 
-let instance_list schl =
-  let tyl = List.map copy schl in
+let instance_def sch =
+  let ty = copy sch in
+  cleanup_types ();
+  ty  
+
+let instance_list env schl =
+  let env = gadt_env env in
+  let tyl = List.map (copy ?env) schl in
   cleanup_types ();
   tyl
 
-let instance_constructor cstr =
+let reified_var_counter = ref Vars.empty
+    
+(* names given to new type constructors. 
+   Used for existential types and 
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  Printf.sprintf "%s#%d" s index
+
+let new_declaration newtype manifest = 
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_newtype_level = newtype;
+    type_loc = Location.none;
+  }
+
+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) ->
+      let process existential = 
+        let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
+        let name =
+          match repr existential with
+            {desc = Tvar (Some name)} -> name
+          | _ -> "ex"
+        in
+        let (id, new_env) =
+          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 
+      in
+      List.iter process cstr.cstr_existentials
+  end;
   cleanup_types ();
   (ty_args, ty_res)
 
@@ -878,7 +1100,9 @@ let instance_declaration decl =
      type_kind = match decl.type_kind with
      | Type_abstract -> Type_abstract
      | Type_variant cl ->
-         Type_variant (List.map (fun (s,tl) -> (s, List.map copy tl)) cl)
+         Type_variant (
+         List.map (fun (s,tl,ot) -> (s, List.map copy tl, may_map copy ot))
+           cl)
      | Type_record (fl, rr) ->
          Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)}
   in
@@ -908,46 +1132,6 @@ let instance_class params cty =
 
 (**** Instanciation for types with free universal variables ****)
 
-module TypeHash = Hashtbl.Make(TypeOps)
-module TypeSet = Set.Make(TypeOps)
-
-type inv_type_expr =
-    { inv_type : type_expr;
-      mutable inv_parents : inv_type_expr list }
-
-let rec inv_type hash pty ty =
-  let ty = repr ty in
-  try
-    let inv = TypeHash.find hash ty in
-    inv.inv_parents <- pty @ inv.inv_parents
-  with Not_found ->
-    let inv = { inv_type = ty; inv_parents = pty } in
-    TypeHash.add hash ty inv;
-    iter_type_expr (inv_type hash [inv]) ty
-
-let compute_univars ty =
-  let inverted = TypeHash.create 17 in
-  inv_type inverted [] ty;
-  let node_univars = TypeHash.create 17 in
-  let rec add_univar univ inv =
-    match inv.inv_type.desc with
-      Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
-    | _ ->
-        try
-          let univs = TypeHash.find node_univars inv.inv_type in
-          if not (TypeSet.mem univ !univs) then begin
-            univs := TypeSet.add univ !univs;
-            List.iter (add_univar univ) inv.inv_parents
-          end
-        with Not_found ->
-          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
-          List.iter (add_univar univ) inv.inv_parents
-  in
-  TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
-    inverted;
-  fun ty ->
-    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
-
 let rec diff_list l1 l2 =
   if l1 == l2 then [] else
   match l1 with [] -> invalid_arg "Ctype.diff_list"
@@ -974,7 +1158,7 @@ let rec copy_sep fixed free bound visited ty =
     t
   else try
     let t, bound_t = List.assq ty visited in
-    let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
     if dl <> [] && conflicts univars dl then raise Not_found;
     t
   with Not_found -> begin
@@ -991,14 +1175,14 @@ let rec copy_sep fixed free bound visited ty =
           let row = row_repr row0 in
           let more = repr row.row_more in
           (* We shall really check the level on the row variable *)
-          let keep = more.desc = Tvar && more.level <> generic_level in
+          let keep = is_Tvar more && more.level <> generic_level in
           let more' = copy_rec more in
-          let fixed' = fixed && (repr more').desc = Tvar in
+          let fixed' = fixed && is_Tvar (repr more') in
           let row = copy_row copy_rec fixed' row keep more' in
           Tvariant row
       | Tpoly (t1, tl) ->
           let tl = List.map repr tl in
-          let tl' = List.map (fun t -> newty Tunivar) tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
           let bound = tl @ bound in
           let visited =
             List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
@@ -1008,9 +1192,15 @@ let rec copy_sep fixed free bound visited ty =
     t
   end
 
-let instance_poly fixed univars sch =
-  let vars = List.map (fun _ -> newvar ()) univars in
-  let pairs = List.map2 (fun u v -> repr u, (v, [])) univars vars in
+let instance_poly ?(keep_names=false) fixed univars sch =
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
   delayed_copy := [];
   let ty = copy_sep fixed (compute_univars sch) [] pairs sch in
   List.iter Lazy.force !delayed_copy;
@@ -1092,6 +1282,7 @@ let check_abbrev_env env =
     previous_env := env
   end
 
+
 (* Expand an abbreviation. The expansion is memorized. *)
 (*
    Assume the level is greater than the path binding time of the
@@ -1130,8 +1321,8 @@ let expand_abbrev_gen kind find_type_expansion env ty =
             end;
           ty
       | None ->
-          let (params, body) =
-            try find_type_expansion path env with Not_found ->
+          let (params, body, lv) =
+            try find_type_expansion level path env with Not_found ->
               raise Cannot_expand
           in
           (* prerr_endline
@@ -1143,12 +1334,26 @@ let expand_abbrev_gen kind find_type_expansion env ty =
               ty.desc <- Tvariant { row with row_name = Some (path, args) }
           | _ -> ()
           end;
+          (* For gadts, remember type as non exportable *)
+          if !trace_gadt_instances then begin
+            match lv with
+              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
   | _ ->
       assert false
 
-let expand_abbrev = expand_abbrev_gen Public Env.find_type_expansion
+(* inside objects and variants we do not want to 
+   use local constraints *)
+let expand_abbrev ty =
+  expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty
 
 let safe_abbrev env ty =
   let snap = Btype.snapshot () in
@@ -1160,7 +1365,7 @@ let safe_abbrev env ty =
 let try_expand_once env ty =
   let ty = repr ty in
   match ty.desc with
-    Tconstr _ -> repr (expand_abbrev env ty)
+    Tconstr (p, _, _) -> repr (expand_abbrev env ty)
   | _ -> raise Cannot_expand
 
 let _ = forward_try_expand_once := try_expand_once
@@ -1170,11 +1375,16 @@ let _ = forward_try_expand_once := try_expand_once
    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
-  begin try
-    try_expand_head env ty'
-  with Cannot_expand ->
-    ty'
-  end
+  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
+  end;
+  ty''
 
 (* Expand once the head of a type *)
 let expand_head_once env ty =
@@ -1198,7 +1408,8 @@ let expand_head env ty =
    normally hidden to the type-checker out of the implementation module of
    the private abbreviation. *)
 
-let expand_abbrev_opt = expand_abbrev_gen Private Env.find_type_expansion_opt
+let expand_abbrev_opt =
+  expand_abbrev_gen Private (fun level -> Env.find_type_expansion_opt)
 
 let try_expand_once_opt env ty =
   let ty = repr ty in
@@ -1238,7 +1449,7 @@ let enforce_constraints env ty =
 let rec full_expand env ty =
   let ty = repr (expand_head env ty) in
   match ty.desc with
-    Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
       newty2 ty.level (Tobject (fi, ref None))
   | _ ->
       ty
@@ -1250,7 +1461,7 @@ let rec full_expand env ty =
 *)
 let generic_abbrev env path =
   try
-    let (_, body) = Env.find_type_expansion path env in
+    let (_, body, _) = Env.find_type_expansion path env in
     (repr body).level = generic_level
   with
     Not_found ->
@@ -1277,8 +1488,11 @@ let rec non_recursive_abbrev env ty0 ty =
         begin try
           non_recursive_abbrev env ty0 (try_expand_once_opt env ty)
         with Cannot_expand ->
-          if !Clflags.recursive_types then () else
-          iter_type_expr (non_recursive_abbrev env ty0) ty
+          if !Clflags.recursive_types &&
+            (in_current_module p || in_pervasives p ||
+             is_datatype (Env.find_type p env))
+          then ()
+          else iter_type_expr (non_recursive_abbrev env ty0) ty
         end
     | Tobject _ | Tvariant _ ->
         ()
@@ -1344,6 +1558,31 @@ let occur env ty0 ty =
     merge type_changed old;
     raise (match exn with Occur -> Unify [] | _ -> exn)
 
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Unify _ -> true
+
+(* checks that a local constraint is non recursive *)
+let rec local_non_recursive_abbrev visited env p ty =
+  let ty = repr ty in
+  if not (List.memq ty !visited) then begin
+    visited := ty :: !visited;
+    match ty.desc with
+      Tconstr(p', args, abbrev) ->
+        if Path.same p p' then raise Recursive_abbrev;
+        begin try
+          local_non_recursive_abbrev visited env p (try_expand_once_opt env ty)
+        with Cannot_expand ->
+          if !Clflags.recursive_types then () else
+          iter_type_expr (local_non_recursive_abbrev visited env p) ty
+        end
+    | Tobject _ | Tvariant _ ->
+        ()
+    | _ ->
+        if !Clflags.recursive_types then () else
+        iter_type_expr (local_non_recursive_abbrev visited env p) ty
+  end
+
+let local_non_recursive_abbrev = local_non_recursive_abbrev (ref [])
 
                    (*****************************)
                    (*  Polymorphic Unification  *)
@@ -1371,8 +1610,6 @@ let rec unify_univar t1 t2 = function
       end
   | [] -> raise (Unify [])
 
-module TypeMap = Map.Make (TypeOps)
-
 (* Test the occurence of free univars in a type *)
 (* that's way too expansive. Must do some kind of cacheing *)
 let occur_univar env ty =
@@ -1393,8 +1630,8 @@ let occur_univar env ty =
         true
     then
       match ty.desc with
-        Tunivar ->
-          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
       | Tpoly (ty, tyl) ->
           let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
           occur_rec bound  ty
@@ -1443,7 +1680,7 @@ let univars_escape env univar_pairs vl ty =
         Tpoly (t, tl) ->
           if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
           else occur t
-      | Tunivar ->
+      | Tunivar _ ->
           if TypeSet.mem t family then raise Occur
       | Tconstr (_, [], _) -> ()
       | Tconstr (p, tl, _) ->
@@ -1553,60 +1790,348 @@ let deep_occur t0 ty =
       abbreviated.  It would be possible to check whether some
       information is indeed lost, but it probably does not worth it.
 *)
-let rec unify env t1 t2 =
-  (* First step: special cases (optimizations) *)
+
+let newtype_level = ref None
+
+let get_newtype_level () = 
+  match !newtype_level with
+  | None -> assert false
+  | Some x -> x
+
+(* a local constraint can be added only if the rhs 
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let newtype_level = get_newtype_level () in
+  let create_fresh_constr lev name = 
+    let decl = new_declaration (Some (newtype_level, newtype_level)) None in
+    let name = get_new_abstract_name name in
+    let (id, new_env) = Env.enter_type name decl !env in    
+    let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil))  in 
+    env := new_env;
+    t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty = 
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let name = match o with Some s -> s | _ -> "ex" in
+          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);
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_abstract_newtype env p = 
+  let decl = Env.find_type p env in 
+  not (decl.type_newtype_level = None) &&
+  decl.type_manifest = None &&
+  decl.type_kind = Type_abstract
+
+(* 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 
+   that the mapping subst holds. 
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs subst 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
+
+and mcomp_list type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (mcomp type_pairs subst env) tl1 tl2
+
+and mcomp_fields type_pairs subst 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;
+  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)
+    pairs
 
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise (Unify [])
+
+and mcomp_row type_pairs subst 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) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []);
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise (Unify [])
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs subst env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs subst env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs subst 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
+  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 else ()
+  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'
+  | Type_variant v1, Type_variant v2 ->
+      mcomp_list type_pairs subst env tl1 tl2;
+      mcomp_variant_description type_pairs subst 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 [])
+
+and mcomp_type_option type_pairs subst env t t' = 
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs subst env t t' 
+  | _ -> raise (Unify []) 
+
+and mcomp_variant_description type_pairs subst env = 
+  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' 
+      then iter xs ys
+      else raise (Unify [])
+    | [],[] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+and mcomp_record_description type_pairs subst 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' 
+        then iter xs ys
+        else raise (Unify [])
+    | [], [] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) () env t1 t2
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty.level < !lowest then lowest := ty.level;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_newtype_level env path = 
+  match (Env.find_type path env).type_newtype_level with
+    Some x -> x
+  | None -> assert false
+        
+let add_gadt_equation env source destination =
+  let destination = duplicate_type destination in 
+  let source_lev = find_newtype_level !env (Path.Pident source) in
+  let decl = new_declaration (Some source_lev) (Some destination) in
+  let newtype_level = get_newtype_level () in
+  env := Env.add_local_constraint source decl newtype_level !env;
+  cleanup_abbrev ()          
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 = 
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+        
+let unify_eq env t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if unify_eq !env t1 t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq !env t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+  
   try
     type_changed := true;
-    match (t1.desc, t2.desc) with
-      (Tvar, Tconstr _) when deep_occur t1 t2 ->
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
         unify2 env t1 t2
-    | (Tconstr _, Tvar) when deep_occur t2 t1 ->
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
         unify2 env t1 t2
-    | (Tvar, _) ->
-        occur env t1 t2; occur_univar env t2;
-        update_level env t1.level t2;
-        link_type t1 t2
-    | (_, Tvar) ->
-        occur env t2 t1; occur_univar env t1;
-        update_level env t2.level t1;
-        link_type t2 t1
-    | (Tunivar, Tunivar) ->
+    | (Tvar _, _) ->
+        occur !env t1 t2; 
+        occur_univar !env t2;
+        link_type t1 t2;
+        update_level !env t1.level t2
+    | (_, Tvar _) ->
+        occur !env t2 t1; 
+        occur_univar !env t1;
+        link_type t2 t1;
+        update_level !env t2.level t1
+    | (Tunivar _, Tunivar _) ->
         unify_univar t1 t2 !univar_pairs;
-        update_level env t1.level t2;
+        update_level !env t1.level t2;
         link_type t1 t2
     | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
-          when Path.same p1 p2
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
             (* This optimization assumes that t1 does not expand to t2
                (and conversely), so we fall back to the general case
                when any of the types has a cached expansion. *)
             && not (has_cached_expansion p1 !a1
                  || has_cached_expansion p2 !a2) ->
-        update_level env t1.level t2;
+        update_level !env t1.level t2;
         link_type t1 t2
     | _ ->
         unify2 env t1 t2
+    end;
+    if reset_tracing then trace_gadt_instances := false;
   with Unify trace ->
+    if reset_tracing then trace_gadt_instances := false;
     raise (Unify ((t1, t2)::trace))
 
 and unify2 env t1 t2 =
   (* Second step: expansion of abbreviations *)
   let rec expand_both t1'' t2'' =
-    let t1' = expand_head_unif env t1 in
-    let t2' = expand_head_unif env t2 in
+    let t1' = expand_head_unif !env t1 in
+    let t2' = expand_head_unif !env t2 in
     (* Expansion may have changed the representative of the types... *)
-    if t1' == t1'' && t2' == t2'' then (t1',t2') else
+    if unify_eq !env t1' t1'' && unify_eq !env t2' t2'' then (t1',t2') else
     expand_both t1' t2'
   in
   let t1', t2' = expand_both t1 t2 in
-  if t1' == t2' then () else
+  let lv = min t1'.level t2'.level in
+  update_level !env lv t2;
+  update_level !env lv t1;
+  if unify_eq !env t1' t2' then () else
 
   let t1 = repr t1 and t2 = repr t2 in
-  if (t1 == t1') || (t2 != t2') then
+  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     -> ()
+  end;
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
     unify3 env t1 t1' t2 t2'
   else
     try unify3 env t2 t2' t1 t1' with Unify trace ->
@@ -1616,132 +2141,151 @@ and unify3 env t1 t1' t2 t2' =
   (* Third step: truly unification *)
   (* Assumes either [t1 == t1'] or [t2 != t2'] *)
   let d1 = t1'.desc and d2 = t2'.desc in
-
   let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
-  occur env t1' t2;
-  update_level env t1'.level t2;
-  link_type t1' t2;
-
-  try
-    begin match (d1, d2) with
-      (Tvar, _) ->
-        occur_univar env t2
-    | (_, Tvar) ->
-        let td1 = newgenty d1 in
-        occur env t2' td1;
-        occur_univar env td1;
-        if t1 == t1' then begin
-          (* The variable must be instantiated... *)
-          let ty = newty2 t1'.level d1 in
-          update_level env t2'.level ty;
-          link_type t2' ty
-        end else begin
-          log_type t1';
-          t1'.desc <- d1;
-          update_level env t2'.level t1;
-          link_type t2' t1
-        end
-    | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
-      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
-        unify env t1 t2; unify env u1 u2;
-        begin match commu_repr c1, commu_repr c2 with
-          Clink r, c2 -> set_commu r c2
-        | c1, Clink r -> set_commu r c1
-        | _ -> ()
-        end
-    | (Ttuple tl1, Ttuple tl2) ->
-        unify_list env tl1 tl2
-    | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
-        unify_list env tl1 tl2
-    | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
-        unify_fields env fi1 fi2;
-        (* Type [t2'] may have been instantiated by [unify_fields] *)
-        (* XXX One should do some kind of unification... *)
-        begin match (repr t2').desc with
-          Tobject (_, {contents = Some (_, va::_)})
-          when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
-            ()
-        | Tobject (_, nm2) ->
-            set_name nm2 !nm1
-        | _ ->
-            ()
-        end
-    | (Tvariant row1, Tvariant row2) ->
-        unify_row env row1 row2
-    | (Tfield _, Tfield _) ->           (* Actually unused *)
-        unify_fields env t1' t2'
-    | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
-        begin match field_kind_repr kind with
-          Fvar r when f <> dummy_method -> set_kind r Fabsent
-        | _      -> raise (Unify [])
-        end
-    | (Tnil, Tnil) ->
-        ()
-    | (Tpoly (t1, []), Tpoly (t2, [])) ->
-        unify env t1 t2
-    | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
-        enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env)
-    | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 ->
-        unify_list env tl1 tl2
-    | (_, _) ->
-        raise (Unify [])
-    end;
-
-(* XXX Commentaires + changer "create_recursion" *)
-    if create_recursion then begin
-      match t2.desc with
-        Tconstr (p, tl, abbrev) ->
-          forget_abbrev abbrev p;
-          let t2'' = expand_head_unif env t2 in
-          if not (closed_parameterized_type tl t2'') then
-            link_type (repr t2) (repr t2')
-      | _ ->
-          () (* t2 has already been expanded by update_level *)
-    end
 
-(*
-    (*
-       Can only be done afterwards, once the row variable has
-       (possibly) been instantiated.
-    *)
-    if t1 != t1' (* && t2 != t2' *) then begin
-      match (t1.desc, t2.desc) with
-        (Tconstr (p, ty::_, _), _)
-            when ((repr ty).desc <> Tvar)
-              && weak_abbrev p
-              && not (deep_occur t1 t2) ->
-          update_level env t1.level t2;
-          link_type t1 t2
-      | (_, Tconstr (p, ty::_, _))
-            when ((repr ty).desc <> Tvar)
-              && weak_abbrev p
-              && not (deep_occur t2 t1) ->
-          update_level env t2.level t1;
-          link_type t2 t1;
-          link_type t1' t2'
-      | _ ->
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      occur !env t1 t2';
+      occur_univar !env t2;
+      link_type t1' t2;
+  | (_, Tvar _) ->
+      occur !env t2 t1';
+      occur_univar !env t1;
+      link_type t2' t1;
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+      begin match !umode with
+      | Expression ->
+          occur !env t1' t2';
+          link_type t1' t2
+      | Pattern ->
+          add_type_equality t1' t2'
+      end;
+      try match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || not !generate_equations
+          || in_current_module p1 || in_pervasives p1
+          || is_datatype (Env.find_type p1 !env)
+          then
+            unify_list env tl1 tl2
+          else
+            set_mode Pattern ~generate:false (fun () -> unify_list env 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'
+        && !generate_equations ->
+          let source,destination =
+            if find_newtype_level !env path > find_newtype_level !env path'
+            then  p,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 ->
+          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 ->
+          reify env t1' ;
+          local_non_recursive_abbrev !env (Path.Pident p) t1';
+          add_gadt_equation env p t1'
+      | (Tconstr (_,[],_), _) | (_, Tconstr (_,[],_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          mcomp !env t1' t2'
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          unify_row env row1 row2
+      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+          begin match field_kind_repr kind with
+            Fvar r when f <> dummy_method ->
+              set_kind r Fabsent;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      -> raise (Unify [])
+          end
+      | (Tnil, Tnil) ->
           ()
-    end
-*)
-  with Unify trace ->
-    t1'.desc <- d1;
-    raise (Unify trace)
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+        when Path.same p1 p2 && n1 = n2 ->
+          unify_list env tl1 tl2
+      | (_, _) ->
+          raise (Unify [])
+      with Unify trace ->
+        t1'.desc <- d1;
+        raise (Unify trace)
+  end;
+  (* XXX Commentaires + changer "create_recursion" *)
+  if create_recursion then begin
+    match t2.desc with
+      Tconstr (p, tl, abbrev) ->
+        forget_abbrev abbrev p;
+        let t2'' = expand_head_unif !env t2 in
+        if not (closed_parameterized_type tl t2'') then
+          link_type (repr t2) (repr t2')
+    | _ ->
+        () (* t2 has already been expanded by update_level *)
+  end
 
 and unify_list env tl1 tl2 =
   if List.length tl1 <> List.length tl2 then
     raise (Unify []);
   List.iter2 (unify env) tl1 tl2
 
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> log_type ty; ty.desc <- Tvar name
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
 and unify_fields env ty1 ty2 =          (* Optimization *)
   let (fields1, rest1) = flatten_fields ty1
   and (fields2, rest2) = flatten_fields ty2 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
   let l1 = (repr ty1).level and l2 = (repr ty2).level in
-  let va =
-    if miss1 = [] then rest2
-    else if miss2 = [] then rest1
-    else newty2 (min l1 l2) Tvar
-  in
+  let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
   let d1 = rest1.desc and d2 = rest2.desc in
   try
     unify env (build_fields l1 miss1 va) rest2;
@@ -1749,9 +2293,12 @@ and unify_fields env ty1 ty2 =          (* Optimization *)
     List.iter
       (fun (n, k1, t1, k2, t2) ->
         unify_kind k1 k2;
-        try unify env t1 t2 with Unify trace ->
-          raise (Unify ((newty (Tfield(n, k1, t1, va)),
-                         newty (Tfield(n, k2, t2, va)))::trace)))
+        try 
+          if !trace_gadt_instances then update_level !env va.level t1;
+          unify env t1 t2 
+        with Unify trace ->
+          raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)),
+                         newty (Tfield(n, k2, t2, newty Tnil)))::trace)))
       pairs
   with exn ->
     log_type rest1; rest1.desc <- d1;
@@ -1768,13 +2315,13 @@ and unify_kind k1 k2 =
   | (Fpresent, Fpresent)          -> ()
   | _                             -> assert false
 
-and unify_pairs env tpl =
+and unify_pairs mode env tpl =
   List.iter (fun (t1, t2) -> unify env t1 t2) tpl
 
 and unify_row env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let rm1 = row_more row1 and rm2 = row_more row2 in
-  if rm1 == rm2 then () else
+  if unify_eq !env rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   if r1 <> [] && r2 <> [] then begin
     let ht = Hashtbl.create (List.length r1) in
@@ -1788,8 +2335,7 @@ and unify_row env row1 row2 =
   let more =
     if row1.row_fixed then rm1 else
     if row2.row_fixed then rm2 else
-    newgenvar ()
-  in update_level env (min rm1.level rm2.level) more;
+    newty2 (min rm1.level rm2.level) (Tvar None) in
   let fixed = row1.row_fixed || row2.row_fixed
   and closed = row1.row_closed || row2.row_closed in
   let keep switch =
@@ -1829,14 +2375,17 @@ and unify_row env row1 row2 =
       let t1 = mkvariant [] true and t2 = mkvariant rest false in
       raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
     end;
+    (* The following test is not principal... should rather use Tnil *)
     let rm = row_more row in
+    if !trace_gadt_instances && rm.desc = Tnil then () else
+    if !trace_gadt_instances then
+      update_level !env rm.level (newgenty (Tvariant row));
     if row.row_fixed then
-      if row0.row_more == rm then () else
-      if rm.desc = Tvar then link_type rm row0.row_more else
-      unify env rm row0.row_more
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
     else
-      let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
-      update_level env rm.level ty;
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level !env rm.level ty;
       link_type rm ty
   in
   let md1 = rm1.desc and md2 = rm2.desc in
@@ -1879,7 +2428,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
       in
       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
       (* Is this handling of levels really principal? *)
-      List.iter (update_level env (repr more).level) (tl1' @ tl2');
+      List.iter (update_level !env (repr more).level) (tl1' @ tl2');
       let e = ref None in
       let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
       and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
@@ -1889,10 +2438,12 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Rabsent, Rabsent -> ()
   | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
       set_row_field e1 f2;
+      update_level !env (repr more).level t2;
       (try List.iter (fun t1 -> unify env t1 t2) tl
       with exn -> e1 := None; raise exn)
   | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
       set_row_field e2 f1;
+      update_level !env (repr more).level t1;
       (try List.iter (unify env t1) tl
       with exn -> e2 := None; raise exn)
   | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
@@ -1905,23 +2456,43 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
 let unify env ty1 ty2 =
   try
     unify env ty1 ty2
-  with Unify trace ->
-    raise (Unify (expand_trace env trace))
+  with
+    Unify trace ->
+      raise (Unify (expand_trace !env trace))
+  | Recursive_abbrev ->
+      raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)]))
+
+let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    newtype_level := Some lev;
+    set_mode Pattern (fun () -> unify env ty1 ty2);
+    newtype_level := None;
+    TypePairs.clear unify_eq_set;
+  with e ->
+    TypePairs.clear unify_eq_set;
+    match e with
+      Unify e -> raise (Unify e)
+    | e -> newtype_level := None; raise e
 
 let unify_var env t1 t2 =
   let t1 = repr t1 and t2 = repr t2 in
   if t1 == t2 then () else
   match t1.desc with
-    Tvar ->
+    Tvar _ ->
+      let reset_tracing = check_trace_gadt_instances env in
       begin try
         occur env t1 t2;
         update_level env t1.level t2;
-        link_type t1 t2
+        link_type t1 t2;
+        if reset_tracing then trace_gadt_instances := false;
       with Unify trace ->
-        raise (Unify (expand_trace env ((t1,t2)::trace)))
+        if reset_tracing then trace_gadt_instances := false;
+        let expanded_trace = expand_trace env ((t1,t2)::trace) in 
+        raise (Unify expanded_trace)
       end
   | _ ->
-      unify env t1 t2
+      unify (ref env) t1 t2
 
 let _ = unify' := unify_var
 
@@ -1930,25 +2501,32 @@ let unify_pairs env ty1 ty2 pairs =
   unify env ty1 ty2
 
 let unify env ty1 ty2 =
-  univar_pairs := [];
-  unify env ty1 ty2
+  unify_pairs (ref env) ty1 ty2 []
+
 
 
 (**** Special cases of unification ****)
 
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  if reset_tracing then trace_gadt_instances := false;
+  t
+
 (*
    Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
    In label mode, label mismatch is accepted when
    (1) the requested label is ""
    (2) the original label is not optional
 *)
+
 let rec filter_arrow env t l =
-  let t = expand_head_unif env t in
+  let t = expand_head_trace env t in
   match t.desc with
-    Tvar ->
-      let t1 = newvar () and t2 = newvar () in
-      let t' = newty (Tarrow (l, t1, t2, Cok)) in
-      update_level env t.level t';
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
       link_type t t';
       (t1, t2)
   | Tarrow(l', t1, t2, _)
@@ -1959,9 +2537,9 @@ let rec filter_arrow env t l =
 
 (* Used by [filter_method]. *)
 let rec filter_method_field env name priv ty =
-  let ty = repr ty in
+  let ty = expand_head_trace env ty in
   match ty.desc with
-    Tvar ->
+    Tvar _ ->
       let level = ty.level in
       let ty1 = newvar2 level and ty2 = newvar2 level in
       let ty' = newty2 level (Tfield (name,
@@ -1986,9 +2564,9 @@ let rec filter_method_field env name priv ty =
 
 (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
 let rec filter_method env name priv ty =
-  let ty = expand_head_unif env ty in
+  let ty = expand_head_trace env ty in
   match ty.desc with
-    Tvar ->
+    Tvar _ ->
       let ty1 = newvar () in
       let ty' = newobj ty1 in
       update_level env ty.level ty';
@@ -2024,7 +2602,7 @@ let moregen_occur env level ty =
   let rec occur ty =
     let ty = repr ty in
     if ty.level > level then begin
-      if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur;
+      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
       ty.level <- pivot_level - ty.level;
       match ty.desc with
         Tvariant row when static_row row ->
@@ -2054,9 +2632,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
 
   try
     match (t1.desc, t2.desc) with
-      (Tunivar, Tunivar) ->
-        unify_univar t1 t2 !univar_pairs
-    | (Tvar, _) when may_instantiate inst_nongen t1 ->
+      (Tvar _, _) when may_instantiate inst_nongen t1 ->
         moregen_occur env t1.level t2;
         occur env t1 t2;
         link_type t1 t2
@@ -2073,7 +2649,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
         with Not_found ->
           TypePairs.add type_pairs (t1', t2') ();
           match (t1'.desc, t2'.desc) with
-            (Tvar, _) when may_instantiate inst_nongen t1' ->
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
               moregen_occur env t1'.level t2;
               link_type t1' t2
           | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
@@ -2085,7 +2661,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
           | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                 when Path.same p1 p2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
-          | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) when Path.same p1 p2 && n1 = n2 ->
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+            when Path.same p1 p2 && n1 = n2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               moregen_row inst_nongen type_pairs env row1 row2
@@ -2100,6 +2677,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
           | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
               enter_poly env univar_pairs t1 tl1 t2 tl2
                 (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
           | (_, _) ->
               raise (Unify [])
         end
@@ -2139,7 +2718,8 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
   if rm1 == rm2 then () else
-  let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   let r1, r2 =
     if row2.row_closed then
@@ -2149,9 +2729,9 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
   if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
   then raise (Unify []);
   begin match rm1.desc, rm2.desc with
-    Tunivar, Tunivar ->
+    Tunivar _, Tunivar _ ->
       unify_univar rm1 rm2 !univar_pairs
-  | Tunivar, _ | _, Tunivar ->
+  | Tunivar _, _ | _, Tunivar _ ->
       raise (Unify [])
   | _ when static_row row1 -> ()
   | _ when may_inst ->
@@ -2221,10 +2801,10 @@ let moregeneral env inst_nongen pat_sch subj_sch =
      then copied with [duplicate_type].  That way, its levels won't be
      changed.
   *)
-  let subj = duplicate_type (instance subj_sch) in
+  let subj = duplicate_type (instance env subj_sch) in
   current_level := generic_level;
   (* Duplicate generic variables *)
-  let patt = instance pat_sch in
+  let patt = instance env pat_sch in
   let res =
     try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
       Unify _ -> false
@@ -2242,13 +2822,13 @@ let rec rigidify_rec vars ty =
   if ty.level >= lowest_level then begin
     ty.level <- pivot_level - ty.level;
     match ty.desc with
-    | Tvar ->
+    | Tvar _ ->
         if not (List.memq ty !vars) then vars := ty :: !vars
     | Tvariant row ->
         let row = row_repr row in
         let more = repr row.row_more in
-        if more.desc = Tvar && not row.row_fixed then begin
-          let more' = newty2 more.level Tvar in
+        if is_Tvar more && not row.row_fixed then begin
+          let more' = newty2 more.level more.desc in
           let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
           in link_type more (newty2 ty.level (Tvariant row'))
         end;
@@ -2271,7 +2851,7 @@ let all_distinct_vars env vars =
     (fun ty ->
       let ty = expand_head env ty in
       if List.memq ty !tyl then false else
-      (tyl := ty :: !tyl; ty.desc = Tvar))
+      (tyl := ty :: !tyl; is_Tvar ty))
     vars
 
 let matches env ty ty' =
@@ -2290,6 +2870,11 @@ let matches env ty ty' =
                  (*  Equivalence between parameterized types  *)
                  (*********************************************)
 
+let rec get_object_row ty =
+  match repr ty with
+  | {desc=Tfield (_, _, _, tl)} -> get_object_row tl
+  | ty -> ty
+
 let expand_head_rigid env ty =
   let old = !rigid_variants in
   rigid_variants := true;
@@ -2310,7 +2895,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
 
   try
     match (t1.desc, t2.desc) with
-      (Tvar, Tvar) when rename ->
+      (Tvar _, Tvar _) when rename ->
         begin try
           normalize_subst subst;
           if List.assq t1 !subst != t2 then raise (Unify [])
@@ -2331,12 +2916,13 @@ let rec eqtype rename type_pairs subst env t1 t2 =
         with Not_found ->
           TypePairs.add type_pairs (t1', t2') ();
           match (t1'.desc, t2'.desc) with
-            (Tvar, Tvar) when rename ->
+            (Tvar _, Tvar _) when rename ->
               begin try
                 normalize_subst subst;
                 if List.assq t1' !subst != t2' then raise (Unify [])
               with Not_found ->
-                if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []);
+                if List.exists (fun (_, t) -> t == t2') !subst
+                then raise (Unify []);
                 subst := (t1', t2') :: !subst
               end
           | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
@@ -2348,7 +2934,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
           | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                 when Path.same p1 p2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
-          | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) when Path.same p1 p2 && n1 = n2 ->
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+            when Path.same p1 p2 && n1 = n2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               eqtype_row rename type_pairs subst env row1 row2
@@ -2363,7 +2950,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
           | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
               enter_poly env univar_pairs t1 tl1 t2 tl2
                 (eqtype rename type_pairs subst env)
-          | (Tunivar, Tunivar) ->
+          | (Tunivar _, Tunivar _) ->
               unify_univar t1' t2' !univar_pairs
           | (_, _) ->
               raise (Unify [])
@@ -2377,12 +2964,18 @@ and eqtype_list rename type_pairs subst env tl1 tl2 =
   List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
 
 and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
   let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
   (* Try expansion, needed when called from Includecore.type_manifest *)
   match expand_head_rigid env rest2 with
     {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
   | _ ->
-  let (fields1, rest1) = flatten_fields ty1 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
   eqtype rename type_pairs subst env rest1 rest2;
   if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
@@ -2782,16 +3375,16 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
-let rec lid_of_path sharp = function
+let rec lid_of_path ?(sharp="") = function
     Path.Pident id ->
       Longident.Lident (sharp ^ Ident.name id)
   | Path.Pdot (p1, s, _) ->
-      Longident.Ldot (lid_of_path "" p1, sharp ^ s)
+      Longident.Ldot (lid_of_path p1, sharp ^ s)
   | Path.Papply (p1, p2) ->
-      Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
+      Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
 
 let find_cltype_for_path env p =
-  let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
+  let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
   match cl_abbr.type_manifest with
     Some ty ->
       begin match (repr ty).desc with
@@ -2806,7 +3399,7 @@ let has_constr_row' env t =
 let rec build_subtype env visited loops posi level t =
   let t = repr t in
   match t.desc with
-    Tvar ->
+    Tvar _ ->
       if posi then
         try
           let t' = List.assq t loops in
@@ -2855,13 +3448,13 @@ let rec build_subtype env visited loops posi level t =
              as this occurence might break the occur check.
              XXX not clear whether this correct anyway... *)
           if List.exists (deep_occur ty) tl1 then raise Not_found;
-          ty.desc <- Tvar;
+          ty.desc <- Tvar None;
           let t'' = newvar () in
           let loops = (ty, t'') :: loops in
           (* May discard [visited] as level is going down *)
           let (ty1', c) =
             build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
-          assert (t''.desc = Tvar);
+          assert (is_Tvar t'');
           let nm =
             if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
           t''.desc <- Tobject (ty1', ref nm);
@@ -2960,7 +3553,7 @@ let rec build_subtype env visited loops posi level t =
       let (t1', c) = build_subtype env visited loops posi level t1 in
       if c > Unchanged then (newty (Tpoly(t1', tl)), c)
       else (t, Unchanged)
-  | Tunivar | Tpackage _ ->
+  | Tunivar _ | Tpackage _ ->
       (t, Unchanged)
 
 let enlarge_type env ty =
@@ -2996,6 +3589,23 @@ let private_abbrev env path =
     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
+    (a::nl1', b::nl2') ->
+      if a = b then included nl1' nl2' else
+      a > b && included nl1 nl2'
+  | ([], _) -> true
+  | (_, []) -> false
+
+let rec extract_assoc nl1 nl2 tl2 =
+  match (nl1, nl2, tl2) with
+    (a::nl1', b::nl2, t::tl2) ->
+      if a = b then t :: extract_assoc nl1' nl2 tl2
+      else extract_assoc nl1 nl2 tl2
+  | ([], _, _) -> []
+  | _ -> assert false
+
 let rec subtype_rec env trace t1 t2 cstrs =
   let t1 = repr t1 in
   let t2 = repr t2 in
@@ -3007,7 +3617,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
   with Not_found ->
     TypePairs.add subtypes (t1, t2) ();
     match (t1.desc, t2.desc) with
-      (Tvar, _) | (_, Tvar) ->
+      (Tvar _, _) | (_, Tvar _) ->
         (trace, t1, t2, !univar_pairs)::cstrs
     | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
       || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
@@ -3043,7 +3653,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
     | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
     | (Tobject (f1, _), Tobject (f2, _))
-      when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar ->
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
         (* Same row variable implies same object. *)
         (trace, t1, t2, !univar_pairs)::cstrs
     | (Tobject (f1, _), Tobject (f2, _)) ->
@@ -3066,6 +3676,11 @@ let rec subtype_rec env trace t1 t2 cstrs =
         with Unify _ ->
           (trace, t1, t2, !univar_pairs)::cstrs
         end
+    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2))
+      when Path.same p1 p2 && included nl2 nl1 ->
+        List.map2 (fun t1 t2 -> (trace, t1, t2, !univar_pairs))
+          (extract_assoc nl2 nl1 tl1) tl2
+        @ cstrs
     | (_, _) ->
         (trace, t1, t2, !univar_pairs)::cstrs
   end
@@ -3110,7 +3725,7 @@ and subtype_row env trace row1 row2 cstrs =
   match more1.desc, more2.desc with
     Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
       subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
-  | (Tvar|Tconstr _), (Tvar|Tconstr _)
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
     when row1.row_closed && r1 = [] ->
       List.fold_left
         (fun cstrs (_,f1,f2) ->
@@ -3124,7 +3739,7 @@ and subtype_row env trace row1 row2 cstrs =
           | Rabsent, _ -> cstrs
           | _ -> raise Exit)
         cstrs pairs
-  | Tunivar, Tunivar
+  | Tunivar _, Tunivar _
     when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
       let cstrs =
         subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
@@ -3153,7 +3768,7 @@ let subtype env ty1 ty2 =
   function () ->
     List.iter
       (function (trace0, t1, t2, pairs) ->
-         try unify_pairs env t1 t2 pairs with Unify trace ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
            raise (Subtype (expand_trace env (List.rev trace0),
                            List.tl (List.tl trace))))
       (List.rev cstrs)
@@ -3168,19 +3783,19 @@ let rec unalias_object ty =
   match ty.desc with
     Tfield (s, k, t1, t2) ->
       newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
-  | Tvar | Tnil ->
+  | Tvar _ | Tnil ->
       newty2 ty.level ty.desc
-  | Tunivar ->
+  | Tunivar _ ->
       ty
   | Tconstr _ ->
-      newty2 ty.level Tvar
+      newvar2 ty.level
   | _ ->
       assert false
 
 let unalias ty =
   let ty = repr ty in
   match ty.desc with
-    Tvar | Tunivar ->
+    Tvar _ | Tunivar _ ->
       ty
   | Tvariant row ->
       let row = row_repr row in
@@ -3254,7 +3869,7 @@ let rec normalize_type_rec env visited ty =
               set_name nm None
             else let v' = repr v in
             begin match v'.desc with
-            | Tvar|Tunivar ->
+            | Tvar _ | Tunivar _ ->
                 if v' != v then set_name nm (Some (n, v' :: l))
             | Tnil ->
                 log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
@@ -3296,7 +3911,7 @@ let clear_hash ()   =
 
 let rec nondep_type_rec env id ty =
   match ty.desc with
-    Tvar | Tunivar -> ty
+    Tvar _ | Tunivar _ -> ty
   | Tlink ty -> nondep_type_rec env id ty
   | _ -> try TypeHash.find nondep_hash ty
   with Not_found ->
@@ -3342,7 +3957,7 @@ let rec nondep_type_rec env id ty =
             (* Register new type first for recursion *)
             TypeHash.add nondep_variants more ty';
             let static = static_row row in
-            let more' = if static then newgenvar () else more in
+            let more' = if static then newgenty Tnil else more in
             (* Return a new copy *)
             let row =
               copy_row (nondep_type_rec env id) true row true more' in
@@ -3366,7 +3981,7 @@ let nondep_type env id ty =
 
 let unroll_abbrev id tl ty =
   let ty = repr ty and path = Path.Pident id in
-  if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl)
+  if is_Tvar ty || (List.exists (deep_occur ty) tl)
   || is_object_type path then
     ty
   else
@@ -3385,7 +4000,11 @@ let nondep_type_decl env mid id is_covariant decl =
       | Type_variant cstrs ->
           Type_variant
             (List.map
-               (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl))
+               (fun (c, tl,ret_type_opt) -> 
+                 let ret_type_opt = 
+                   may_map (nondep_type_rec env mid) ret_type_opt
+                 in
+                 (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) 
                cstrs)
       | Type_record(lbls, rep) ->
           Type_record
@@ -3414,6 +4033,8 @@ let nondep_type_decl env mid id is_covariant decl =
       type_manifest = tm;
       type_private = priv;
       type_variance = decl.type_variance;
+      type_newtype_level = None;
+      type_loc = decl.type_loc;
     }
   with Not_found ->
     clear_hash ();
diff --git a/typing/ctype.mli b/typing/ctype.mli
index d7a40184..c4d4ff13 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,6 +24,7 @@ exception Subtype of
 exception Cannot_expand
 exception Cannot_apply
 exception Recursive_abbrev
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
 
 val init_def: int -> unit
         (* Set the initial variable level *)
@@ -40,9 +41,10 @@ val restore_global_level: int -> unit
         (* This pair of functions is only used in Typetexp *)
 
 val newty: type_desc -> type_expr
-val newvar: unit -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
         (* Return a fresh variable *)
-val new_global_var: unit -> type_expr
+val new_global_var: ?name:string -> unit -> type_expr
         (* Return a fresh variable, bound at toplevel
            (as type variables ['a] in type constraints). *)
 val newobj: type_expr -> type_expr
@@ -74,6 +76,7 @@ val set_object_name:
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
 val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+val lid_of_path: ?sharp:string -> Path.t -> Longident.t
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
@@ -103,11 +106,17 @@ val limited_generalize: type_expr -> type_expr -> unit
         (* Only generalize some part of the type
            Make the remaining of the type non-generalizable *)
 
-val instance: type_expr -> type_expr
+val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
         (* Take an instance of a type scheme *)
-val instance_list: type_expr list -> type_expr list
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val instance_def: type_expr -> type_expr
+        (* use defaults *)
+val instance_list: Env.t -> type_expr list -> type_expr list
         (* Take an instance of a list of type schemes *)
 val instance_constructor:
+        ?in_pattern:Env.t ref * int -> 
         constructor_description -> type_expr list * type_expr
         (* Same, for a constructor *)
 val instance_parameterized_type:
@@ -119,6 +128,7 @@ val instance_declaration: type_declaration -> type_declaration
 val instance_class:
         type_expr list -> class_type -> type_expr list * class_type
 val instance_poly:
+        ?keep_names:bool ->
         bool -> type_expr list -> type_expr -> type_expr list * type_expr
         (* Take an instance of a type scheme containing free univars *)
 val instance_label:
@@ -142,6 +152,8 @@ val enforce_constraints: Env.t -> type_expr -> unit
 
 val unify: Env.t -> type_expr -> type_expr -> unit
         (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
+        (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. *)
 val unify_var: Env.t -> type_expr -> type_expr -> unit
         (* Same as [unify], but allow free univars when first type
            is a variable. *)
@@ -151,6 +163,7 @@ val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
         (* A special case of unification (with {m : 'a; 'b}). *)
 val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
         (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
 val deep_occur: type_expr -> type_expr -> bool
 val filter_self_method:
         Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
@@ -244,3 +257,5 @@ val arity: type_expr -> int
 
 val collapse_conj_params: Env.t -> type_expr list -> unit
         (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 80b94132..bc05d2a8 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,41 +18,85 @@
 open Misc
 open Asttypes
 open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let rec free_vars ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty = 
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      ty.level <- pivot_level - ty.level;
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then loop row.row_more
+      | _ ->
+	  iter_type_expr loop ty
+    end
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
 
 let constructor_descrs ty_res cstrs priv =
-  let num_consts = ref 0 and num_nonconsts = ref 0 in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
   List.iter
-    (function (name, []) -> incr num_consts
-            | (name, _)  -> incr num_nonconsts)
+    (fun (name, args, ret) ->
+      if args = [] then incr num_consts else incr num_nonconsts;
+      if ret = None then incr num_normal)
     cstrs;
   let rec describe_constructors idx_const idx_nonconst = function
       [] -> []
-    | (name, ty_args) :: rem ->
+    | (name, ty_args, ty_res_opt) :: rem ->
+	let ty_res = 
+	  match ty_res_opt with
+	  | Some ty_res' -> ty_res'
+	  | None -> ty_res
+	in
         let (tag, descr_rem) =
           match ty_args with
             [] -> (Cstr_constant idx_const,
                    describe_constructors (idx_const+1) idx_nonconst rem)
           | _  -> (Cstr_block idx_nonconst,
                    describe_constructors idx_const (idx_nonconst+1) rem) in
-        let cstr =
-          { cstr_res = ty_res;
+	let existentials = 
+	  match ty_res_opt with
+	  | None -> []
+	  | Some type_ret ->
+	      let res_vars = free_vars type_ret in
+	      let arg_vars = free_vars (newgenty (Ttuple ty_args)) in
+	      TypeSet.elements (TypeSet.diff arg_vars res_vars)
+	in
+	let cstr =
+          { cstr_res = ty_res;    
+	    cstr_existentials = existentials; 
             cstr_args = ty_args;
             cstr_arity = List.length ty_args;
             cstr_tag = tag;
             cstr_consts = !num_consts;
             cstr_nonconsts = !num_nonconsts;
-            cstr_private = priv } in
+	    cstr_normal = !num_normal;
+            cstr_private = priv;
+	    cstr_generalized = ty_res_opt <> None
+	  } in
         (name, cstr) :: descr_rem in
-  describe_constructors 0 0 cstrs
+  describe_constructors 0 0 cstrs 
 
 let exception_descr path_exc decl =
   { cstr_res = Predef.type_exn;
-    cstr_args = decl;
-    cstr_arity = List.length decl;
-    cstr_tag = Cstr_exception path_exc;
+    cstr_existentials = [];
+    cstr_args = decl.exn_args;
+    cstr_arity = List.length decl.exn_args;
+    cstr_tag = Cstr_exception (path_exc, decl.exn_loc);
     cstr_consts = -1;
     cstr_nonconsts = -1;
-    cstr_private = Public }
+    cstr_private = Public;
+    cstr_normal = -1;
+    cstr_generalized = false }
 
 let none = {desc = Ttuple []; level = -1; id = -1}
                                         (* Clearly ill-formed type *)
@@ -84,13 +128,13 @@ exception Constr_not_found
 let rec find_constr tag num_const num_nonconst = function
     [] ->
       raise Constr_not_found
-  | (name, [] as cstr) :: rem ->
+  | (name, ([] as cstr),(_ as ret_type_opt)) :: rem ->
       if tag = Cstr_constant num_const
-      then cstr
+      then (name,cstr,ret_type_opt)
       else find_constr tag (num_const + 1) num_nonconst rem
-  | (name, _ as cstr) :: rem ->
+  | (name, (_ as cstr),(_ as ret_type_opt)) :: rem ->
       if tag = Cstr_block num_nonconst
-      then cstr
+      then (name,cstr,ret_type_opt)
       else find_constr tag num_const (num_nonconst + 1) rem
 
 let find_constr_by_tag tag cstrlist =
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index 283dbd29..bc1190d4 100644
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,10 +19,10 @@ open Asttypes
 open Types
 
 val constructor_descrs:
-  type_expr -> (string * type_expr list) list -> private_flag ->
-    (string * constructor_description) list
+  type_expr -> (string * type_expr list * type_expr option) list ->
+  private_flag -> (string * constructor_description) list
 val exception_descr:
-  Path.t -> type_expr list -> constructor_description
+  Path.t -> exception_declaration -> constructor_description
 val label_descrs:
   type_expr -> (string * mutable_flag * type_expr) list ->
     record_representation -> private_flag ->
@@ -31,4 +31,5 @@ val label_descrs:
 exception Constr_not_found
 
 val find_constr_by_tag:
-  constructor_tag -> (string * type_expr list) list -> string * type_expr list
+  constructor_tag -> (string * type_expr list * type_expr option) list ->
+    string * type_expr list * type_expr option
diff --git a/typing/env.ml b/typing/env.ml
index 6eb55855..7ec2028b 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,10 +20,37 @@ open Asttypes
 open Longident
 open Path
 open Types
-
+open Btype
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Hashtbl.create 16
+    (* This table is used to usage of value declarations.  A declaration is
+       identified with its name and location.  The callback attached to a declaration
+       is called whenever the value is used explicitly (lookup_value) or implicitly
+       (inclusion test between signatures, cf Includemod.value_descriptions). *)
+
+let type_declarations = Hashtbl.create 16
+
+type constructor_usage = [`Positive|`Pattern|`Privatize]
+type constructor_usages =
+    {
+     mutable cu_positive: bool;
+     mutable cu_pattern: bool;
+     mutable cu_privatize: bool;
+    }
+let add_constructor_usage cu = function
+  | `Positive -> cu.cu_positive <- true
+  | `Pattern -> cu.cu_pattern <- true
+  | `Privatize -> cu.cu_privatize <- true
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_privatize = false}
+
+let used_constructors : (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t = Hashtbl.create 16
 
 type error =
     Not_an_interface of string
+  | Wrong_version_interface of string * string
   | Corrupted_interface of string
   | Illegal_renaming of string * string
   | Inconsistent_import of string * string * string
@@ -42,18 +69,57 @@ type summary =
   | Env_cltype of summary * Ident.t * cltype_declaration
   | Env_open of summary * Path.t
 
+module EnvTbl =
+  struct
+    (* A table indexed by identifier, with an extra slot to record usage. *)
+    type 'a t = 'a Ident.tbl * bool ref Ident.tbl
+
+    let empty = (Ident.empty, Ident.empty)
+    let current_slot = ref (ref true)
+
+    let add id x (tbl, slots) =
+      let slot = !current_slot in
+      let slots = if !slot then slots else Ident.add id slot slots in
+      Ident.add id x tbl, slots
+
+    let find_same_not_using id (tbl, _) =
+      Ident.find_same id tbl
+
+    let find_same id (tbl, slots) =
+      (try Ident.find_same id slots := true with Not_found -> ());
+      Ident.find_same id tbl
+
+    let find_name s (tbl, slots) =
+      (try Ident.find_name s slots := true with Not_found -> ());
+      Ident.find_name s tbl
+
+    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 keys (tbl, _) =
+      Ident.keys tbl
+  end
+
 type t = {
-  values: (Path.t * value_description) Ident.tbl;
-  annotations: (Path.t * Annot.ident) Ident.tbl;
-  constrs: constructor_description Ident.tbl;
-  labels: label_description Ident.tbl;
-  types: (Path.t * type_declaration) Ident.tbl;
-  modules: (Path.t * module_type) Ident.tbl;
-  modtypes: (Path.t * modtype_declaration) Ident.tbl;
-  components: (Path.t * module_components) Ident.tbl;
-  classes: (Path.t * class_declaration) Ident.tbl;
-  cltypes: (Path.t * cltype_declaration) Ident.tbl;
-  summary: summary
+  values: (Path.t * value_description) EnvTbl.t;
+  annotations: (Path.t * Annot.ident) EnvTbl.t;
+  constrs: constructor_description EnvTbl.t;
+  labels: label_description EnvTbl.t;
+  constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
+  types: (Path.t * type_declaration) EnvTbl.t;
+  modules: (Path.t * module_type) EnvTbl.t;
+  modtypes: (Path.t * modtype_declaration) EnvTbl.t;
+  components: (Path.t * module_components) EnvTbl.t;
+  classes: (Path.t * class_declaration) EnvTbl.t;
+  cltypes: (Path.t * cltype_declaration) EnvTbl.t;
+  summary: summary;
+  local_constraints: bool;
+  gadt_instances: (int * TypeSet.t ref) list;
+  in_signature: bool;
 }
 
 and module_components = module_components_repr Lazy.t
@@ -67,6 +133,8 @@ and structure_components = {
   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_modules: (string, (module_type Lazy.t * int)) Tbl.t;
   mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
@@ -85,19 +153,24 @@ and functor_components = {
 }
 
 let empty = {
-  values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
-  labels = Ident.empty; types = Ident.empty;
-  modules = Ident.empty; modtypes = Ident.empty;
-  components = Ident.empty; classes = Ident.empty;
-  cltypes = Ident.empty;
-  summary = Env_empty }
+  values = EnvTbl.empty; annotations = 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; 
+  summary = Env_empty; local_constraints = false; gadt_instances = [];
+  in_signature = false;
+ }
+
+let in_signature env = {env with in_signature = true}
 
 let diff_keys is_local tbl1 tbl2 =
-  let keys2 = Ident.keys tbl2 in
+  let keys2 = EnvTbl.keys tbl2 in
   List.filter
     (fun id ->
-      is_local (Ident.find_same id tbl2) &&
-      try ignore (Ident.find_same id tbl1); false with Not_found -> true)
+      is_local (EnvTbl.find_same_not_using id tbl2) &&
+      try ignore (EnvTbl.find_same_not_using id tbl1); false with Not_found -> true)
     keys2
 
 let is_ident = function
@@ -107,7 +180,7 @@ let is_ident = function
 let is_local (p, _) = is_ident p
 
 let is_local_exn = function
-    {cstr_tag = Cstr_exception p} -> is_ident p
+    {cstr_tag = Cstr_exception (p, _)} -> is_ident p
   | _ -> false
 
 let diff env1 env2 =
@@ -147,7 +220,7 @@ type pers_struct =
     ps_flags: pers_flags list }
 
 let persistent_structures =
-  (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
+  (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)
 
 (* Consistency between persistent structures *)
 
@@ -166,11 +239,17 @@ let check_consistency filename crcs =
 let read_pers_struct modname filename =
   let ic = open_in_bin filename in
   try
-    let buffer = String.create (String.length cmi_magic_number) in
-    really_input ic buffer 0 (String.length cmi_magic_number);
+    let buffer = Misc.input_bytes ic (String.length cmi_magic_number) in
     if buffer <> cmi_magic_number then begin
       close_in ic;
-      raise(Error(Not_an_interface filename))
+      let pre_len = String.length cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len = String.sub cmi_magic_number 0 pre_len then
+      begin
+        let msg = if buffer < cmi_magic_number then "an older" else "a newer" in
+         raise (Error (Wrong_version_interface (filename, msg)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
     end;
     let (name, sign) = input_value ic in
     let crcs = input_value ic in
@@ -194,22 +273,40 @@ let read_pers_struct modname filename =
         if not !Clflags.recursive_types then
           raise(Error(Need_recursive_types(ps.ps_name, !current_unit))))
       ps.ps_flags;
-    Hashtbl.add persistent_structures modname ps;
+    Hashtbl.add persistent_structures modname (Some ps);
     ps
   with End_of_file | Failure _ ->
     close_in ic;
     raise(Error(Corrupted_interface(filename)))
 
 let find_pers_struct name =
-  try
-    Hashtbl.find persistent_structures name
-  with Not_found ->
-    read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi"))
+  if name = "*predef*" then raise Not_found;
+  let r =
+    try Some (Hashtbl.find persistent_structures name)
+    with Not_found -> None
+  in
+  match r with
+  | Some None -> raise Not_found
+  | Some (Some sg) -> sg
+  | None ->
+      let filename =
+        try find_in_path_uncap !load_path (name ^ ".cmi")
+        with Not_found ->
+          Hashtbl.add persistent_structures name None;
+          raise Not_found
+      in
+      read_pers_struct name filename
 
 let reset_cache () =
   current_unit := "";
   Hashtbl.clear persistent_structures;
-  Consistbl.clear crc_units
+  Consistbl.clear crc_units;
+  Hashtbl.clear value_declarations;
+  Hashtbl.clear type_declarations
+
+let reset_missing_cmis () =
+  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
 
 let set_unit_name name =
   current_unit := name
@@ -220,7 +317,7 @@ let rec find_module_descr path env =
   match path with
     Pident id ->
       begin try
-        let (p, desc) = Ident.find_same id env.components
+        let (p, desc) = EnvTbl.find_same id env.components
         in desc
       with Not_found ->
         if Ident.persistent id
@@ -246,7 +343,7 @@ let rec find_module_descr path env =
 let find proj1 proj2 path env =
   match path with
     Pident id ->
-      let (p, data) = Ident.find_same id (proj1 env)
+      let (p, data) = EnvTbl.find_same id (proj1 env)
       in data
   | Pdot(p, s, pos) ->
       begin match Lazy.force(find_module_descr p env) with
@@ -262,6 +359,8 @@ let find_value =
   find (fun env -> env.values) (fun sc -> sc.comp_values)
 and find_type =
   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 =
@@ -272,12 +371,13 @@ and find_cltype =
 (* 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. *)
-let find_type_expansion path env =
+let find_type_expansion ?level path env =
   let decl = find_type path env in
   match decl.type_manifest with
   | Some body when decl.type_private = Public
               || decl.type_kind <> Type_abstract
-              || Btype.has_constr_row body -> (decl.type_params, body)
+              || Btype.has_constr_row body ->
+                  (decl.type_params, body, may_map snd decl.type_newtype_level)
   (* The manifest type of Private abstract data types without
      private row are still considered unknown to the type system.
      Hence, this case is caught by the following clause that also handles
@@ -293,7 +393,7 @@ let find_type_expansion_opt path env =
   match decl.type_manifest with
   (* The manifest type of Private abstract data types can still get
      an approximation using their manifest type. *)
-  | Some body -> (decl.type_params, body)
+  | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
   | _ -> raise Not_found
 
 let find_modtype_expansion path env =
@@ -305,7 +405,7 @@ let find_module path env =
   match path with
     Pident id ->
       begin try
-        let (p, data) = Ident.find_same id env.modules
+        let (p, data) = EnvTbl.find_same id env.modules
         in data
       with Not_found ->
         if Ident.persistent id then
@@ -329,7 +429,7 @@ let rec lookup_module_descr lid env =
   match lid with
     Lident s ->
       begin try
-        Ident.find_name s env.components
+        EnvTbl.find_name s env.components
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
@@ -359,7 +459,7 @@ and lookup_module lid env =
   match lid with
     Lident s ->
       begin try
-        Ident.find_name s env.modules
+        EnvTbl.find_name s env.modules
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
@@ -390,7 +490,7 @@ and lookup_module lid env =
 let lookup proj1 proj2 lid env =
   match lid with
     Lident s ->
-      Ident.find_name s (proj1 env)
+      EnvTbl.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
       begin match Lazy.force desc with
@@ -406,7 +506,7 @@ let lookup proj1 proj2 lid env =
 let lookup_simple proj1 proj2 lid env =
   match lid with
     Lident s ->
-      Ident.find_name s (proj1 env)
+      EnvTbl.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
       begin match Lazy.force desc with
@@ -419,6 +519,8 @@ let lookup_simple proj1 proj2 lid env =
   | Lapply(l1, l2) ->
       raise Not_found
 
+let has_local_constraints env = env.local_constraints
+
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
 let lookup_annot id e =
@@ -436,6 +538,138 @@ and lookup_class =
 and lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
+let mark_value_used name vd =
+  try Hashtbl.find value_declarations (name, vd.val_loc) ()
+  with Not_found -> ()
+
+let mark_type_used name vd =
+  try Hashtbl.find type_declarations (name, vd.type_loc) ()
+  with Not_found -> ()
+
+let mark_constructor_used usage name vd constr =
+  try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
+  with Not_found -> ()
+
+let mark_exception_used usage ed constr =
+  try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage
+  with Not_found -> ()
+
+let set_value_used_callback name vd callback =
+  let key = (name, vd.val_loc) in
+  try
+    let old = Hashtbl.find value_declarations key in
+    Hashtbl.replace value_declarations key (fun () -> old (); callback ())
+      (* this is to support cases like:
+               let x = let x = 1 in x in x
+         where the two declarations have the same location
+         (e.g. resulting from Camlp4 expansion of grammar entries) *)
+  with Not_found ->
+    Hashtbl.add value_declarations key callback
+
+let set_type_used_callback name td callback =
+  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)
+
+let lookup_value lid env =
+  let (_, desc) as r = lookup_value lid env in
+  mark_value_used (Longident.last lid) desc;
+  r
+
+let lookup_type lid env =
+  let (_, desc) as r = lookup_type lid env in
+  mark_type_used (Longident.last lid) desc;
+  r
+
+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
+
+let ty_path = function
+  | {desc=Tconstr(path, _, _)} -> path
+  | _ -> assert false
+
+let lookup_constructor lid env =
+  let desc = lookup_constructor lid env in
+  mark_type_path env (ty_path desc.cstr_res);
+  desc
+
+let mark_constructor usage env name desc =
+  match desc.cstr_tag with
+  | Cstr_exception (_, loc) ->
+      begin
+        try Hashtbl.find used_constructors ("exn", loc, name) usage
+        with Not_found -> ()
+      end
+  | _ ->
+      let ty_path = ty_path desc.cstr_res in
+      let ty_decl = try find_type ty_path env with Not_found -> assert false in
+      let ty_name = Path.last ty_path in
+      mark_constructor_used usage ty_name ty_decl name
+
+let lookup_label lid env =
+  let desc = lookup_label lid env in
+  mark_type_path env (ty_path desc.lbl_res);
+  desc
+
+let lookup_class lid env =
+  let (_, desc) as r = lookup_class lid env in
+  (* special support for Typeclass.unbound_class *)
+  if Path.name desc.cty_path = "" then ignore (lookup_type lid env)
+  else mark_type_path env desc.cty_path;
+  r
+
+let lookup_cltype lid env =
+  let (_, desc) as r = lookup_cltype lid env in
+  if Path.name desc.clty_path = "" then ignore (lookup_type lid env)
+  else mark_type_path env desc.clty_path;
+  mark_type_path env desc.clty_path;
+  r
+
+(* GADT instance tracking *)
+
+let add_gadt_instance_level lv env =
+  {env with
+   gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
+
+let is_Tlink = function {desc = Tlink _} -> true | _ -> false
+
+let gadt_instance_level env t =
+  let rec find_instance = function
+      [] -> None
+    | (lv, r) :: rem ->
+        if TypeSet.exists is_Tlink !r then
+          (* Should we use set_typeset ? *)
+          r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
+        if TypeSet.mem t !r then Some lv else find_instance rem
+  in find_instance env.gadt_instances
+
+let add_gadt_instances env lv tl =
+  let r =
+    try List.assoc lv env.gadt_instances with Not_found -> assert false in
+  (* Format.eprintf "Added";
+  List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl;
+  Format.eprintf "@."; *)
+  set_typeset r (List.fold_right TypeSet.add tl !r)
+
+(* Only use this after expand_head! *)
+let add_gadt_instance_chain env lv t =
+  let r =
+    try List.assoc lv env.gadt_instances with Not_found -> assert false in
+  let rec add_instance t =
+    let t = repr t in
+    if not (TypeSet.mem t !r) then begin
+      (* Format.eprintf "@ %a" !Btype.print_raw t; *)
+      set_typeset r (TypeSet.add t !r);
+      match t.desc with
+        Tconstr (p, _, memo) ->
+          may add_instance (find_expans Private p !memo)
+      | _ -> ()
+    end
+  in
+  (* Format.eprintf "Added chain"; *)
+  add_instance t
+  (* Format.eprintf "@." *)
+
 (* Expand manifest module type names at the top of the given module type *)
 
 let rec scrape_modtype mty env =
@@ -451,11 +685,13 @@ let rec scrape_modtype mty env =
 (* Compute constructor descriptions *)
 
 let constructors_of_type ty_path decl =
+  let handle_variants cstrs = 
+    Datarepr.constructor_descrs
+      (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+      cstrs decl.type_private
+  in
   match decl.type_kind with
-    Type_variant cstrs ->
-      Datarepr.constructor_descrs
-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
-        cstrs decl.type_private
+  | Type_variant cstrs -> handle_variants cstrs
   | Type_record _ | Type_abstract -> []
 
 (* Compute label descriptions *)
@@ -464,7 +700,7 @@ let labels_of_type ty_path decl =
   match decl.type_kind with
     Type_record(labels, rep) ->
       Datarepr.label_descrs
-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+        (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
         labels rep decl.type_private
   | Type_variant _ | Type_abstract -> []
 
@@ -514,8 +750,9 @@ let rec components_of_module env sub path mty =
     Tmty_signature sg ->
       let c =
         { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
-          comp_constrs = 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
@@ -540,14 +777,19 @@ let rec components_of_module env sub path mty =
             let decl' = Subst.type_declaration sub 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;
             List.iter
               (fun (name, descr) ->
                 c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
-              (constructors_of_type path decl');
+              constructors;
+	    let labels = labels_of_type path decl' in
             List.iter
               (fun (name, descr) ->
                 c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
-              (labels_of_type path decl');
+              (labels);
             env := store_type_infos id path decl !env
         | Tsig_exception(id, decl) ->
             let decl' = Subst.exception_declaration sub decl in
@@ -594,40 +836,86 @@ let rec components_of_module env sub path mty =
   | Tmty_ident p ->
         Structure_comps {
           comp_values = Tbl.empty; comp_annotations = Tbl.empty;
-          comp_constrs = Tbl.empty;
-          comp_labels = Tbl.empty; comp_types = 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 })
 
 (* Insertion of bindings by identifier + path *)
 
-and store_value id path decl env =
+and check_usage loc id warn tbl =
+  if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin
+    let name = Ident.name id in
+    let key = (name, loc) in
+    if Hashtbl.mem tbl key then ()
+    else let used = ref false in
+    Hashtbl.add tbl key (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and store_value ?check id path decl env =
+  begin match check with Some f -> check_usage decl.val_loc id f value_declarations | None -> () end;
   { env with
-    values = Ident.add id (path, decl) env.values;
+    values = EnvTbl.add id (path, decl) env.values;
     summary = Env_value(env.summary, id, decl) }
 
 and store_annot id path annot env =
   if !Clflags.annotations then
     { env with
-      annotations = Ident.add id (path, annot) env.annotations }
+      annotations = EnvTbl.add id (path, annot) env.annotations }
   else env
 
 and store_type id path info env =
+  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
+
+  if not env.in_signature && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
+  then begin
+    let ty = Ident.name id in
+    List.iter
+      (fun (c, _) ->
+        let k = (ty, loc, c) in
+        if not (Hashtbl.mem used_constructors k) then
+          let used = constructor_usages () in
+          Hashtbl.add used_constructors k (add_constructor_usage used);
+          if not (ty = "" || ty.[0] = '_')
+          then !add_delayed_check_forward
+              (fun () ->
+                if not used.cu_positive then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_constructor
+                       (c, used.cu_pattern, used.cu_privatize)
+                    )
+              )
+      )
+      constructors
+  end;
   { env with
     constrs =
       List.fold_right
         (fun (name, descr) constrs ->
-          Ident.add (Ident.create name) descr constrs)
-        (constructors_of_type path info)
+          EnvTbl.add (Ident.create name) descr 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 ->
-          Ident.add (Ident.create name) descr labels)
-        (labels_of_type path info)
+          EnvTbl.add (Ident.create name) descr labels)
+        labels
         env.labels;
-    types = Ident.add id (path, info) env.types;
+    types = EnvTbl.add id (path, info) env.types;
     summary = Env_type(env.summary, id, info) }
 
 and store_type_infos id path info env =
@@ -637,35 +925,55 @@ and store_type_infos id path info env =
      keep track of type abbreviations (e.g. type t = float) in the
      computation of label representations. *)
   { env with
-    types = Ident.add id (path, info) env.types;
+    types = EnvTbl.add id (path, info) env.types;
     summary = Env_type(env.summary, id, info) }
 
 and store_exception id path decl env =
+  let loc = decl.exn_loc in
+  if not env.in_signature && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_exception ("", false))
+  then begin
+    let ty = "exn" in
+    let c = Ident.name id in
+    let k = (ty, loc, c) in
+    if not (Hashtbl.mem used_constructors k) then begin
+      let used = constructor_usages () in
+      Hashtbl.add used_constructors k (add_constructor_usage used);
+      !add_delayed_check_forward
+        (fun () ->
+          if not used.cu_positive then
+            Location.prerr_warning loc
+              (Warnings.Unused_exception
+                 (c, used.cu_pattern)
+              )
+        )
+    end;
+  end;
   { env with
-    constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
+    constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs;
     summary = Env_exception(env.summary, id, decl) }
 
 and store_module id path mty env =
   { env with
-    modules = Ident.add id (path, mty) env.modules;
+    modules = EnvTbl.add id (path, mty) env.modules;
     components =
-      Ident.add id (path, components_of_module env Subst.identity path mty)
+      EnvTbl.add id (path, components_of_module env Subst.identity path mty)
                    env.components;
     summary = Env_module(env.summary, id, mty) }
 
 and store_modtype id path info env =
   { env with
-    modtypes = Ident.add id (path, info) env.modtypes;
+    modtypes = EnvTbl.add id (path, info) env.modtypes;
     summary = Env_modtype(env.summary, id, info) }
 
 and store_class id path desc env =
   { env with
-    classes = Ident.add id (path, desc) env.classes;
+    classes = EnvTbl.add id (path, desc) env.classes;
     summary = Env_class(env.summary, id, desc) }
 
 and store_cltype id path desc env =
   { env with
-    cltypes = Ident.add id (path, desc) env.cltypes;
+    cltypes = EnvTbl.add id (path, desc) env.cltypes;
     summary = Env_cltype(env.summary, id, desc) }
 
 (* Compute the components of a functor application in a path. *)
@@ -690,8 +998,8 @@ let _ =
 
 (* Insertion of bindings by identifier *)
 
-let add_value id desc env =
-  store_value id (Pident id) desc env
+let add_value ?check id desc env =
+  store_value ?check id (Pident id) desc env
 
 let add_annot id annot env =
   store_annot id (Pident id) annot env
@@ -714,12 +1022,21 @@ and add_class id ty env =
 and add_cltype id ty env =
   store_cltype id (Pident id) ty env
 
+let add_local_constraint id info elv env =
+  match info with
+    {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
+      (* elv is the expansion level, lv is the definition level *)
+      let env =
+        add_type id {info with type_newtype_level = Some (lv, elv)} env in
+      { env with local_constraints = true }
+  | _ -> assert false
+
 (* 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 enter_value = enter store_value
+let enter_value ?check = enter (store_value ?check)
 and enter_type = enter store_type
 and enter_exception = enter store_exception
 and enter_module = enter store_module
@@ -784,6 +1101,18 @@ let open_pers_signature name env =
   let ps = find_pers_struct name in
   open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
 
+let open_signature ?(loc = Location.none) root sg env =
+  if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") then begin
+    let used = ref false in
+    !add_delayed_check_forward
+      (fun () ->
+        if not !used then
+          Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+      );
+    EnvTbl.with_slot used (open_signature root sg) env
+  end else
+    open_signature root sg env
+
 (* Read a signature from a file *)
 
 let read_signature modname filename =
@@ -832,7 +1161,7 @@ let save_signature_with_imports sg modname filename imports =
         ps_crcs = crcs;
         ps_filename = filename;
         ps_flags = flags } in
-    Hashtbl.add persistent_structures modname ps;
+    Hashtbl.add persistent_structures modname (Some ps);
     Consistbl.set crc_units modname crc filename
   with exn ->
     close_out oc;
@@ -856,16 +1185,19 @@ open Format
 
 let report_error ppf = function
   | Not_an_interface filename -> fprintf ppf
-      "%s@ is not a compiled interface" filename
+      "%a@ is not a compiled interface" Location.print_filename filename
+  | Wrong_version_interface (filename, older_newer) -> fprintf ppf
+      "%a@ is not a compiled interface for this version of OCaml.@.\
+       It seems to be for %s version of OCaml." Location.print_filename filename older_newer
   | Corrupted_interface filename -> fprintf ppf
-      "Corrupted compiled interface@ %s" filename
+      "Corrupted compiled interface@ %a" Location.print_filename filename
   | Illegal_renaming(modname, filename) -> fprintf ppf
-      "Wrong file naming: %s@ contains the compiled interface for@ %s"
-      filename modname
+      "Wrong file naming: %a@ contains the compiled interface for@ %s"
+      Location.print_filename filename modname
   | Inconsistent_import(name, source1, source2) -> fprintf ppf
-      "@[The files %s@ and %s@ \
+      "@[The files %a@ and %a@ \
               make inconsistent assumptions@ over interface %s@]"
-      source1 source2 name
+      Location.print_filename source1 Location.print_filename source2 name
   | Need_recursive_types(import, export) ->
       fprintf ppf
         "@[Unit %s imports from %s, which uses recursive types.@ %s@]"
diff --git a/typing/env.mli b/typing/env.mli
index 8f00972a..599daf88 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,17 +26,26 @@ val diff: t -> t -> Ident.t list
 
 val find_value: Path.t -> t -> value_description
 val find_type: Path.t -> t -> type_declaration
+val find_constructors: Path.t -> t -> constructor_description list
 val find_module: Path.t -> t -> module_type
 val find_modtype: Path.t -> t -> modtype_declaration
 val find_class: Path.t -> t -> class_declaration
 val find_cltype: Path.t -> t -> cltype_declaration
 
-val find_type_expansion: Path.t -> t -> type_expr list * type_expr
-val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
+val find_type_expansion:
+    ?level:int -> Path.t -> t -> type_expr list * type_expr * int option
+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 has_local_constraints: t -> bool
+val add_gadt_instance_level: int -> t -> t
+val gadt_instance_level: t -> type_expr -> int option
+val add_gadt_instances: t -> int -> type_expr list -> unit
+val add_gadt_instance_chain: t -> int -> type_expr -> unit
+
 (* Lookup by long identifiers *)
 
 val lookup_value: Longident.t -> t -> Path.t * value_description
@@ -51,7 +60,7 @@ val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
 
 (* Insertion by identifier *)
 
-val add_value: Ident.t -> value_description -> t -> t
+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
@@ -59,6 +68,7 @@ val add_module: Ident.t -> module_type -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
 val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> cltype_declaration -> t -> t
+val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t
 
 (* Insertion of all fields of a signature. *)
 
@@ -68,12 +78,12 @@ 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: Path.t -> signature -> t -> t
+val open_signature: ?loc:Location.t -> Path.t -> signature -> t -> t
 val open_pers_signature: string -> t -> t
 
 (* Insertion by name *)
 
-val enter_value: string -> value_description -> t -> Ident.t * t
+val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t
 val enter_type: string -> type_declaration -> t -> Ident.t * t
 val enter_exception: string -> exception_declaration -> t -> Ident.t * t
 val enter_module: string -> module_type -> t -> Ident.t * t
@@ -83,6 +93,7 @@ val enter_cltype: string -> cltype_declaration -> t -> Ident.t * t
 
 (* Initialize the cache of in-core module interfaces. *)
 val reset_cache: unit -> unit
+val reset_missing_cmis: unit -> unit
 
 (* Remember the name of the current compilation unit. *)
 val set_unit_name: string -> unit
@@ -130,6 +141,7 @@ val summary: t -> summary
 
 type error =
     Not_an_interface of string
+  | Wrong_version_interface of string * string
   | Corrupted_interface of string
   | Illegal_renaming of string * string
   | Inconsistent_import of string * string * string
@@ -141,6 +153,22 @@ open Format
 
 val report_error: formatter -> error -> unit
 
+
+val mark_value_used: string -> value_description -> unit
+val mark_type_used: string -> type_declaration -> unit
+
+type constructor_usage = [`Positive|`Pattern|`Privatize]
+val mark_constructor_used: constructor_usage -> string -> type_declaration -> string -> unit
+val mark_constructor: constructor_usage -> t -> string -> constructor_description -> unit
+val mark_exception_used: constructor_usage -> exception_declaration -> string -> unit
+
+val in_signature: t -> t
+
+val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit
+val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit
+
 (* Forward declaration to break mutual recursion with Includemod. *)
 val check_modtype_inclusion:
       (t -> module_type -> Path.t -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref
diff --git a/typing/ident.ml b/typing/ident.ml
index c5bc09f4..4196bb83 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/ident.mli b/typing/ident.mli
index 03e2eee4..e26490a9 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 0bb47b52..8dc35115 100644
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)
diff --git a/typing/includeclass.mli b/typing/includeclass.mli
index 5596056d..f5bc98a0 100644
--- a/typing/includeclass.mli
+++ b/typing/includeclass.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)
diff --git a/typing/includecore.ml b/typing/includecore.ml
index a0883192..55113e1b 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -61,7 +61,10 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
     Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
       let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
       Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
-      (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) &&
+      begin match row1.row_more with
+        {desc=Tvar _|Tconstr _|Tnil} -> true
+      | _ -> false
+      end &&
       let r1, r2, pairs =
         Ctype.merge_row_fields row1.row_fields row2.row_fields in
       (not row2.row_closed ||
@@ -91,7 +94,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
       let (fields2,rest2) = Ctype.flatten_fields fi2 in
       Ctype.equal env true (ty1::params1) (rest2::params2) &&
       let (fields1,rest1) = Ctype.flatten_fields fi1 in
-      (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
+      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
       let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
       miss2 = [] &&
       let tl1, tl2 =
@@ -163,19 +166,27 @@ let report_type_mismatch first second decl ppf =
 let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
   match cstrs1, cstrs2 with
     [], []           -> []
-  | [], (cstr2,_)::_ -> [Field_missing (true, cstr2)]
-  | (cstr1,_)::_, [] -> [Field_missing (false, cstr1)]
-  | (cstr1, arg1)::rem1, (cstr2, arg2)::rem2 ->
+  | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)]
+  | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)]
+  | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 ->
       if cstr1 <> cstr2 then [Field_names (n, cstr1, cstr2)] else
       if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else
-      if Misc.for_all2
-          (fun ty1 ty2 ->
-            Ctype.equal env true (ty1::decl1.type_params)
-                                 (ty2::decl2.type_params))
-          arg1 arg2
-      then compare_variants env decl1 decl2 (n+1) rem1 rem2
-      else [Field_type cstr1]
-
+      match ret1, ret2 with
+      | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> 
+	  [Field_type cstr1]
+      | Some _, None | None, Some _ ->
+	  [Field_type cstr1]
+      | _ ->      
+	  if Misc.for_all2
+	      (fun ty1 ty2 ->
+		Ctype.equal env true (ty1::decl1.type_params)
+		  (ty2::decl2.type_params))
+	      (arg1) (arg2) 
+	  then 
+	    compare_variants env decl1 decl2 (n+1) rem1 rem2
+	  else [Field_type cstr1]
+	      
+	    
 let rec compare_records env decl1 decl2 n labels1 labels2 =
   match labels1, labels2 with
     [], []           -> []
@@ -189,12 +200,19 @@ let rec compare_records env decl1 decl2 n labels1 labels2 =
       then compare_records env decl1 decl2 (n+1) rem1 rem2
       else [Field_type lab1]
 
-let type_declarations env id decl1 decl2 =
+let type_declarations env name decl1 id decl2 =
   if decl1.type_arity <> decl2.type_arity then [Arity] else
   if not (private_flags decl1 decl2) then [Privacy] else
   let err = match (decl1.type_kind, decl2.type_kind) with
       (_, Type_abstract) -> []
     | (Type_variant cstrs1, Type_variant cstrs2) ->
+        let usage =
+          if decl1.type_private = Private || decl2.type_private = Public
+          then `Positive else `Privatize
+        in
+        List.iter
+          (fun (c, _, _) -> Env.mark_constructor_used usage name decl1 c)
+          cstrs1;
         compare_variants env decl1 decl2 1 cstrs1 cstrs2
     | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
         let err = compare_records env decl1 decl2 1 labels1 labels2 in
@@ -237,13 +255,13 @@ let type_declarations env id decl1 decl2 =
 (* Inclusion between exception declarations *)
 
 let exception_declarations env ed1 ed2 =
-  Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1 ed2
+  Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1.exn_args ed2.exn_args
 
 (* Inclusion between class types *)
 let encode_val (mut, ty) rem =
   begin match mut with
     Asttypes.Mutable   -> Predef.type_unit
-  | Asttypes.Immutable -> Btype.newgenty Tvar
+  | Asttypes.Immutable -> Btype.newgenvar ()
   end
   ::ty::rem
 
diff --git a/typing/includecore.mli b/typing/includecore.mli
index a2af04ba..17515a8e 100644
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -36,8 +36,8 @@ type type_mismatch =
 val value_descriptions:
     Env.t -> value_description -> value_description -> module_coercion
 val type_declarations:
-    Env.t -> Ident.t ->
-    type_declaration -> type_declaration -> type_mismatch list
+    Env.t -> string ->
+    type_declaration -> Ident.t -> type_declaration -> type_mismatch list
 val exception_declarations:
     Env.t -> exception_declaration -> exception_declaration -> bool
 (*
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 4b9d4ff3..bc981dde 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,7 +19,7 @@ open Path
 open Types
 open Typedtree
 
-type error =
+type symptom =
     Missing_field of Ident.t
   | Value_descriptions of Ident.t * value_description * value_description
   | Type_declarations of Ident.t * type_declaration
@@ -38,6 +38,10 @@ type error =
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
 exception Error of error list
 
 (* All functions "blah env x1 x2" check that x1 is included in x2,
@@ -46,51 +50,55 @@ exception Error of error list
 
 (* Inclusion between value descriptions *)
 
-let value_descriptions env subst id vd1 vd2 =
+let value_descriptions env cxt subst id vd1 vd2 =
+  Env.mark_value_used (Ident.name id) vd1;
   let vd2 = Subst.value_description subst vd2 in
   try
     Includecore.value_descriptions env vd1 vd2
   with Includecore.Dont_match ->
-    raise(Error[Value_descriptions(id, vd1, vd2)])
+    raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
 
 (* Inclusion between type declarations *)
 
-let type_declarations env subst id decl1 decl2 =
+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 id decl1 decl2 in
-  if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
+  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)])
 
 (* Inclusion between exception declarations *)
 
-let exception_declarations env subst id decl1 decl2 =
+let exception_declarations env cxt subst id decl1 decl2 =
+  Env.mark_exception_used `Positive decl1 (Ident.name id);
   let decl2 = Subst.exception_declaration subst decl2 in
   if Includecore.exception_declarations env decl1 decl2
   then ()
-  else raise(Error[Exception_declarations(id, decl1, decl2)])
+  else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
 
 (* Inclusion between class declarations *)
 
-let class_type_declarations env subst id decl1 decl2 =
+let class_type_declarations env cxt subst id decl1 decl2 =
   let decl2 = Subst.cltype_declaration subst decl2 in
   match Includeclass.class_type_declarations env decl1 decl2 with
     []     -> ()
-  | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
+  | reason ->
+      raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
 
-let class_declarations env subst id decl1 decl2 =
+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[Class_declarations(id, decl1, decl2, reason)])
+  | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
 
 (* Expand a module type identifier when possible *)
 
 exception Dont_match
 
-let expand_module_path env path =
+let expand_module_path env cxt path =
   try
     Env.find_modtype_expansion path env
   with Not_found ->
-    raise(Error[Unbound_modtype_path path])
+    raise(Error[cxt, Unbound_modtype_path path])
 
 (* Extract name, kind and ident from a signature item *)
 
@@ -128,28 +136,29 @@ let simplify_structure_coercion cc =
    Return the restriction that transforms a value of the smaller type
    into a value of the bigger type. *)
 
-let rec modtypes env subst mty1 mty2 =
+let rec modtypes env cxt subst mty1 mty2 =
   try
-    try_modtypes env subst mty1 mty2
+    try_modtypes env cxt subst mty1 mty2
   with
     Dont_match ->
-      raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
+      raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
   | Error reasons ->
-      raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
+      raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
+                  :: reasons))
 
-and try_modtypes env subst mty1 mty2 =
+and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
     (_, Tmty_ident p2) ->
-      try_modtypes2 env mty1 (Subst.modtype subst mty2)
+      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
   | (Tmty_ident p1, _) ->
-      try_modtypes env subst (expand_module_path env p1) mty2
+      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
   | (Tmty_signature sig1, Tmty_signature sig2) ->
-      signatures env subst sig1 sig2
+      signatures env cxt subst sig1 sig2
   | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
       let arg2' = Subst.modtype subst arg2 in
-      let cc_arg = modtypes env Subst.identity arg2' arg1 in
+      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
       let cc_res =
-        modtypes (Env.add_module param1 arg2' env)
+        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
           (Subst.add_module param2 (Pident param1) subst) res1 res2 in
       begin match (cc_arg, cc_res) with
           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
@@ -158,22 +167,22 @@ and try_modtypes env subst mty1 mty2 =
   | (_, _) ->
       raise Dont_match
 
-and try_modtypes2 env mty1 mty2 =
+and try_modtypes2 env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
     (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
       Tcoerce_none
   | (_, Tmty_ident p2) ->
-      try_modtypes env Subst.identity mty1 (expand_module_path env p2)
+      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
       assert false
 
 (* Inclusion between signatures *)
 
-and signatures env subst sig1 sig2 =
+and signatures env cxt subst sig1 sig2 =
   (* Environment used to check inclusion of components *)
   let new_env =
-    Env.add_signature sig1 env in
+    Env.add_signature sig1 (Env.in_signature env) in
   (* 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
@@ -202,7 +211,7 @@ and signatures env subst sig1 sig2 =
   let rec pair_components subst paired unpaired = function
       [] ->
         begin match unpaired with
-            [] -> signature_components new_env subst (List.rev paired)
+            [] -> signature_components new_env cxt subst (List.rev paired)
           | _  -> raise(Error unpaired)
         end
     | item2 :: rem ->
@@ -234,7 +243,7 @@ and signatures env subst sig1 sig2 =
             ((item1, item2, pos1) :: paired) unpaired rem
         with Not_found ->
           let unpaired =
-            if report then Missing_field id2 :: unpaired else unpaired in
+            if report then (cxt, 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 *)
@@ -242,65 +251,67 @@ and signatures env subst sig1 sig2 =
 
 (* Inclusion between signature components *)
 
-and signature_components env subst = function
+and signature_components env cxt subst = function
     [] -> []
   | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
-      let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
+      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> signature_components env subst rem
-      | _ -> (pos, cc) :: signature_components env subst rem
+        Val_prim p -> signature_components env cxt subst rem
+      | _ -> (pos, cc) :: signature_components env cxt subst rem
       end
   | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
-      type_declarations env subst id1 tydecl1 tydecl2;
-      signature_components env subst rem
+      type_declarations env cxt subst id1 tydecl1 tydecl2;
+      signature_components env cxt subst rem
   | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
     :: rem ->
-      exception_declarations env subst id1 excdecl1 excdecl2;
-      (pos, Tcoerce_none) :: signature_components env subst rem
+      exception_declarations env cxt subst id1 excdecl1 excdecl2;
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
       let cc =
-        modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-      (pos, cc) :: signature_components env subst rem
+        modtypes env (Module id1::cxt) subst
+          (Mtype.strengthen env mty1 (Pident id1)) mty2 in
+      (pos, cc) :: signature_components env cxt subst rem
   | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
-      modtype_infos env subst id1 info1 info2;
-      signature_components env subst rem
+      modtype_infos env cxt subst id1 info1 info2;
+      signature_components env cxt subst rem
   | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
-      class_declarations env subst id1 decl1 decl2;
-      (pos, Tcoerce_none) :: signature_components env subst rem
+      class_declarations env cxt subst id1 decl1 decl2;
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
-      class_type_declarations env subst id1 info1 info2;
-      signature_components env subst rem
+      class_type_declarations env cxt subst id1 info1 info2;
+      signature_components env cxt subst rem
   | _ ->
       assert false
 
 (* Inclusion between module type specifications *)
 
-and modtype_infos env subst id info1 info2 =
+and modtype_infos env cxt subst id info1 info2 =
   let info2 = Subst.modtype_declaration subst info2 in
+  let cxt' = Modtype id :: cxt in
   try
     match (info1, info2) with
       (Tmodtype_abstract, Tmodtype_abstract) -> ()
     | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
     | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
-        check_modtype_equiv env mty1 mty2
+        check_modtype_equiv env cxt' mty1 mty2
     | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
-        check_modtype_equiv env (Tmty_ident(Pident id)) mty2
+        check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
   with Error reasons ->
-    raise(Error(Modtype_infos(id, info1, info2) :: reasons))
+    raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
 
-and check_modtype_equiv env mty1 mty2 =
+and check_modtype_equiv env cxt mty1 mty2 =
   match
-    (modtypes env Subst.identity mty1 mty2,
-     modtypes env Subst.identity mty2 mty1)
+    (modtypes env cxt Subst.identity mty1 mty2,
+     modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (_, _) -> raise(Error [Modtype_permutation])
+  | (_, _) -> raise(Error [cxt, Modtype_permutation])
 
 (* Simplified inclusion check between module types (for Env) *)
 
 let check_modtype_inclusion env mty1 path1 mty2 =
   try
-    ignore(modtypes env Subst.identity
+    ignore(modtypes env [] Subst.identity
                     (Mtype.strengthen env mty1 path1) mty2)
   with Error reasons ->
     raise Not_found
@@ -312,44 +323,55 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion
 
 let compunit impl_name impl_sig intf_name intf_sig =
   try
-    signatures Env.initial Subst.identity impl_sig intf_sig
+    signatures Env.initial [] Subst.identity impl_sig intf_sig
   with Error reasons ->
-    raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
+    raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
 
-(* Hide the substitution parameter to the outside world *)
+(* Hide the context and substitution parameters to the outside world *)
 
-let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
 let type_declarations env id decl1 decl2 =
-  type_declarations env Subst.identity id decl1 decl2
+  type_declarations env [] Subst.identity id decl1 decl2
 
 (* Error report *)
 
 open Format
 open Printtyp
 
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
 let include_err ppf = function
   | Missing_field id ->
       fprintf ppf "The field `%a' is required but not provided" ident id
   | Value_descriptions(id, d1, d2) ->
       fprintf ppf
-       "@[Values do not match:@ \
-        %a@;<1 -2>is not included in@ %a@]"
-       (value_description id) d1 (value_description id) d2
+        "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
+        (value_description id) d1 (value_description id) d2;
+      show_locs ppf (d1.val_loc, d2.val_loc);
   | Type_declarations(id, d1, d2, errs) ->
-      fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a@]"
+      fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
         "Type declarations do not match"
         (type_declaration id) d1
         "is not included in"
         (type_declaration id) d2
+        show_locs (d1.type_loc, d2.type_loc)
         (Includecore.report_type_mismatch
            "the first" "the second" "declaration") errs
   | Exception_declarations(id, d1, d2) ->
       fprintf ppf
        "@[Exception declarations do not match:@ \
         %a@;<1 -2>is not included in@ %a@]"
-      (exception_declaration id) d1
-      (exception_declaration id) d2
+        (exception_declaration id) d1
+        (exception_declaration id) d2;
+      show_locs ppf (d1.exn_loc, d2.exn_loc)
   | Module_types(mty1, mty2)->
       fprintf ppf
        "@[Modules do not match:@ \
@@ -384,9 +406,65 @@ let include_err ppf = function
   | Unbound_modtype_path path ->
       fprintf ppf "Unbound module type %a" Printtyp.path path
 
-let report_error ppf = function
-  |  [] -> ()
-  | err :: errs ->
-      let print_errs ppf errs =
-         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
-      fprintf ppf "@[%a%a@]" include_err err print_errs errs
+let rec context ppf = function
+    Module id :: rem ->
+      fprintf ppf "@[<2>module %a%a@]" ident id args rem
+  | Modtype id :: rem ->
+      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
+  | Body x :: rem ->
+      fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
+  | Arg x :: rem ->
+      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
+  | [] ->
+      fprintf ppf ""
+and context_mty ppf = function
+    (Module _ | Modtype _) :: _ as rem ->
+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+  | cxt -> context ppf cxt
+and args ppf = function
+    Body x :: rem ->
+      fprintf ppf "(%a)%a" ident x args rem
+  | Arg x :: rem ->
+      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
+  | cxt ->
+      fprintf ppf " :@ %a" context_mty cxt
+
+let path_of_context = function
+    Module id :: rem ->
+      let rec subm path = function
+          [] -> path
+        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
+        | _ -> assert false
+      in subm (Pident id) rem
+  | _ -> assert false
+
+let context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "In module %a:@ " path (path_of_context 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 buffer = ref ""
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if String.length !buffer < size then buffer := String.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+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
+    else if !pe then (fprintf ppf "...@ "; pe := false)
+  in
+  let print_errs ppf = List.iter (include_err' ppf) in
+  fprintf ppf "@[%a%a@]" print_errs errs include_err err
diff --git a/typing/includemod.mli b/typing/includemod.mli
index 347fd2d6..c1c9c1f0 100644
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ val compunit: string -> signature -> string -> signature -> module_coercion
 val type_declarations:
       Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
 
-type error =
+type symptom =
     Missing_field of Ident.t
   | Value_descriptions of Ident.t * value_description * value_description
   | Type_declarations of Ident.t * type_declaration
@@ -43,6 +43,10 @@ type error =
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
 exception Error of error list
 
 val report_error: formatter -> error list -> unit
diff --git a/typing/mtype.ml b/typing/mtype.ml
index dddc65a0..5700b59e 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -48,8 +48,9 @@ and strengthen_sig env sg p =
       sigelt :: strengthen_sig env rem p
   | Tsig_type(id, decl, rs) :: rem ->
       let newdecl =
-        match decl.type_manifest with
-          Some ty when decl.type_private = Public -> decl
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
         | _ ->
             let manif =
               Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
@@ -110,12 +111,16 @@ let nondep_supertype env mid mty =
       match item with
         Tsig_value(id, d) ->
           Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
-                          val_kind = d.val_kind}) :: rem'
+                          val_kind = d.val_kind;
+                          val_loc = d.val_loc;
+                         }) :: rem'
       | Tsig_type(id, d, rs) ->
           Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
           :: rem'
       | Tsig_exception(id, d) ->
-          Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
+          let d = {exn_args = List.map (Ctype.nondep_type env mid) d.exn_args;
+                   exn_loc = d.exn_loc} in
+          Tsig_exception(id, d) :: rem'
       | Tsig_module(id, mty, rs) ->
           Tsig_module(id, nondep_mty env va mty, rs) :: rem'
       | Tsig_modtype(id, d) ->
diff --git a/typing/mtype.mli b/typing/mtype.mli
index b15b09ec..a24756dc 100644
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 68166173..0bfd8797 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*                  Projet Cristal, INRIA Rocquencourt                 *)
 (*                                                                     *)
@@ -265,9 +265,9 @@ let out_type = ref print_out_type
 (* Class types *)
 
 let type_parameter ppf (ty, (co, cn)) =
-  fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
-    (*if co then if cn then "!" else "+" else if cn then "-" else "?"*)
-    ty
+  fprintf ppf "%s%s"
+    (if not cn then "+" else if not co then "-" else "")
+    (if ty = "_" then ty else "'"^ty)
 
 let print_out_class_params ppf =
   function
@@ -350,7 +350,7 @@ and print_out_sig_item ppf =
         (if vir_flag then " virtual" else "") print_out_class_params params
         name !out_class_type clt
   | Osig_exception (id, tyl) ->
-      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
+      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None)
   | Osig_modtype (name, Omty_abstract) ->
       fprintf ppf "@[<2>module type %s@]" name
   | Osig_modtype (name, mty) ->
@@ -428,12 +428,27 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
     print_name_args
     print_out_tkind ty
     print_constraints constraints
-and print_out_constr ppf (name, tyl) =
-  match tyl with
-    [] -> fprintf ppf "%s" name
-  | _ ->
-      fprintf ppf "@[<2>%s of@ %a@]" name
-        (print_typlist print_simple_out_type " *") tyl
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "%s" name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+
 and print_out_label ppf (name, mut, arg) =
   fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
     !out_type arg
diff --git a/typing/oprint.mli b/typing/oprint.mli
index 7a5121ae..5724355b 100644
--- a/typing/oprint.mli
+++ b/typing/oprint.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*                  Projet Cristal, INRIA Rocquencourt                 *)
 (*                                                                     *)
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 80c28ea0..7d95672a 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*     Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -54,7 +54,7 @@ type out_type =
   | Otyp_object of (string * out_type) list * bool option
   | Otyp_record of (string * bool * out_type) list
   | Otyp_stuff of string
-  | Otyp_sum of (string * out_type list) list
+  | Otyp_sum of (string * out_type list * out_type option) list
   | Otyp_tuple of out_type list
   | Otyp_var of bool * string
   | Otyp_variant of
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index d73f79af..99bb5afe 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,16 +51,10 @@ let is_absent_pat p = match p.pat_desc with
 | Tpat_variant (tag, _, row) -> is_absent tag row
 | _ -> false
 
-let sort_fields args =
-  Sort.list
-    (fun (lbl1,_) (lbl2,_) -> lbl1.lbl_pos <= lbl2.lbl_pos)
-    args
-
 let records_args l1 l2 =
-  let l1 = sort_fields l1
-  and l2 = sort_fields l2 in
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
   let rec combine r1 r2 l1 l2 = match l1,l2 with
-  | [],[] -> r1,r2
+  | [],[] -> 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 ->
@@ -159,10 +153,10 @@ open Format
 ;;
 
 let get_constr_name tag ty tenv  = match tag with
-| Cstr_exception path -> Path.name path
+| Cstr_exception (path, _) -> Path.name path
 | _ ->
   try
-    let name,_ = get_constr tag ty tenv in name
+    let name,_,_ = get_constr tag ty tenv in name
   with
   | Datarepr.Constr_not_found -> "*Unknown constructor*"
 
@@ -294,13 +288,10 @@ 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
   p
 
-
 let extract_fields omegas arg =
   List.map
     (fun (lbl,_) ->
@@ -309,15 +300,6 @@ let extract_fields omegas arg =
       with Not_found -> omega)
     omegas
 
-
-
-let sort_record p = match p.pat_desc with
-| Tpat_record args ->
-    make_pat
-      (Tpat_record (sort_fields args))
-      p.pat_type p.pat_env
-| _ -> p
-
 let all_record_args lbls = match lbls with
 | ({lbl_all=lbl_all},_)::_ ->
     let t =
@@ -395,23 +377,22 @@ let discr_pat q pss =
   | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
   | (({pat_desc = Tpat_record largs} as p)::_)::pss ->
       let new_omegas =
-        List.fold_left
-          (fun r (lbl,_) ->
+        List.fold_right
+          (fun (lbl,_) r ->
             try
               let _ = get_field lbl.lbl_pos r in
               r
             with Not_found ->
               (lbl,omega)::r)
-          (record_arg acc)
-          largs in
+          largs (record_arg acc)
+      in
       acc_pat
         (make_pat (Tpat_record new_omegas) p.pat_type p.pat_env)
         pss
   | _ -> acc in
 
   match normalize_pat q with
-  | {pat_desc= (Tpat_any | Tpat_record _)} as q ->
-      sort_record (acc_pat q pss)
+  | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss
   | q -> q
 
 (*
@@ -615,11 +596,32 @@ let row_of_pat pat =
   not.
 *)
 
-let full_match closing env =  match env with
+let generalized_constructor x = 
+  match x with 
+    ({pat_desc = Tpat_construct(c,_);pat_env=env},_) ->
+      c.cstr_generalized
+  | _ -> assert false
+
+let clean_env env = 
+  let rec loop = 
+    function
+      | [] -> []
+      | x :: xs ->
+	  if generalized_constructor x then loop xs else x :: loop xs
+  in
+  loop env
+
+let full_match ignore_generalized closing env =  match env with
 | ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ ->
     false
-| ({pat_desc = Tpat_construct(c,_)},_) :: _ ->
-    List.length env = c.cstr_consts + c.cstr_nonconsts
+| ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> 
+    if ignore_generalized then
+      (* remove generalized constructors; those cases will be handled separately *)
+      let env = clean_env env in 
+      List.length env = c.cstr_normal
+    else
+      List.length env = c.cstr_consts + c.cstr_nonconsts
+
 | ({pat_desc = Tpat_variant _} as p,_) :: _ ->
     let fields =
       List.map
@@ -653,6 +655,11 @@ let full_match closing env =  match env with
 | ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
 | _ -> fatal_error "Parmatch.full_match"
 
+let full_match_gadt env = match env with
+  | ({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 _)},_)} as p,_) :: _ ->
     let path = get_type_path p.pat_type p.pat_env in
@@ -708,24 +715,44 @@ let rec pat_of_constrs ex_pat = function
         (pat_of_constr ex_pat cstr,
          pat_of_constrs ex_pat rem, None)}
 
+exception Not_an_adt
+
+let rec adt_path env ty =
+  match get_type_descr ty env with
+  | {type_kind=Type_variant constr_list} ->
+      begin match (Ctype.repr ty).desc with
+      | Tconstr (path,_,_) ->
+	  path
+      | _ -> assert false end
+  | {type_manifest = Some _} ->
+      adt_path env (Ctype.expand_head_once env (clean_copy ty))
+  | _ -> raise Not_an_adt
+;;
+
+let rec map_filter f  = 
+  function
+      [] -> []
+    | x :: xs ->
+	match f x with
+	| None -> map_filter f xs
+	| Some y -> y :: map_filter f xs
+
 (* Sends back a pattern that complements constructor tags all_tag *)
-let complete_constrs p all_tags = match p.pat_desc with
-| Tpat_construct (c,_) ->
-    begin try
-      let not_tags = complete_tags  c.cstr_consts c.cstr_nonconsts all_tags in
-      List.map
-        (fun tag ->
-          let _,targs = get_constr tag p.pat_type p.pat_env in
-          {c with
-      cstr_tag = tag ;
-      cstr_args = targs ;
-      cstr_arity = List.length targs})
-        not_tags
-with
-| Datarepr.Constr_not_found ->
-    fatal_error "Parmatch.complete_constr: constr_not_found"
-    end
-| _ -> fatal_error "Parmatch.complete_constr"
+let complete_constrs p all_tags = 
+  match p.pat_desc with
+  | Tpat_construct (c,_) ->
+      begin try
+	let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+	let constrs = Env.find_constructors (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)
+	  constrs
+      with
+      | Datarepr.Constr_not_found ->
+	  fatal_error "Parmatch.complete_constr: constr_not_found"
+      end
+  | _ -> fatal_error "Parmatch.complete_constr"
 
 
 (* Auxiliary for build_other *)
@@ -750,7 +777,7 @@ let build_other ext env =  match env with
       (Tpat_construct
          ({c with
            cstr_tag=(Cstr_exception
-            (Path.Pident (Ident.create "*exception*")))},
+            (Path.Pident (Ident.create "*exception*"), Location.none))},
           []))
       Ctype.none Env.empty
 | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
@@ -872,6 +899,20 @@ let build_other ext env =  match env with
 | [] -> omega
 | _ -> omega
 
+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
+          | _ -> 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
+	let pats = List.map (pat_of_constr p) cnstrs in
+        (* List.iter (Format.eprintf "%a@." top_pretty) pats;
+           Format.eprintf "@.@."; *)
+        pats
+    | _ -> assert false
+	  
 (*
   Core function :
   Is the last row of pattern matrix pss + qs satisfiable ?
@@ -909,7 +950,7 @@ let rec satisfiable pss qs = match pss with
           (* first column of pss is made of variables only *)
         | [] -> satisfiable (filter_extra pss) qs
         | constrs  ->
-            if full_match false constrs then
+            if full_match false false constrs then
               List.exists
                 (fun (p,pss) ->
                   not (is_absent_pat p) &&
@@ -934,13 +975,36 @@ type 'a result =
   | Rnone           (* No matching value *)
   | Rsome of 'a     (* This matching value *)
 
-let rec try_many f = function
+let rec orify_many =
+  let rec orify x y = 
+    make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env	
+  in
+  function
+    | [] -> assert false
+    | [x] -> x
+    | x :: xs -> orify x (orify_many xs)
+  
+let rec try_many  f = function
   | [] -> Rnone
-  | x::rest ->
-      begin match f x with
-      | Rnone -> try_many f rest
+  | (p,pss)::rest ->
+      match f (p,pss) with
+      | Rnone -> try_many  f rest
       | r -> r
-      end
+
+
+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')
+		  
+
 
 let rec exhaust ext pss n = match pss with
 | []    ->  Rsome (omegas n)
@@ -966,7 +1030,7 @@ let rec exhaust ext pss n = match pss with
             | Rsome r -> Rsome (set_args p r)
             | r       -> r in
         if
-          full_match false constrs && not (should_extend ext constrs)
+          full_match true false constrs && not (should_extend ext constrs)
         then
           try_many try_non_omega constrs
         else
@@ -989,6 +1053,99 @@ let rec exhaust ext pss n = match pss with
               | Empty -> fatal_error "Parmatch.exhaust"
     end
 
+let combinations f lst lst' = 
+  let rec iter2 x = 
+    function
+	[] -> []
+      | y :: ys ->
+	  f x y :: iter2 x ys
+  in
+  let rec iter =
+    function
+	[] -> []
+      | x :: xs -> iter2 x lst' @ iter xs
+  in
+  iter lst
+    
+(* strictly more powerful than exhaust; however, exhaust
+   was kept for backwards compatibility *)
+let rec exhaust_gadt ext pss n = match pss with
+| []    ->  Rsome [omegas n]
+| []::_ ->  Rnone
+| pss   ->
+    let q0 = discr_pat omega pss in
+    begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+    | [] ->
+        begin match exhaust_gadt ext (filter_extra pss) (n-1) with
+        | Rsome r -> Rsome (List.map (fun row -> q0::row) r)
+        | r -> r
+      end
+    | constrs ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Rnone
+          else
+            match
+              exhaust_gadt
+                ext pss (List.length (simple_match_args p omega) + n - 1)
+            with
+            | Rsome r -> Rsome (List.map (fun row ->  (set_args p row)) r)
+            | r       -> r in
+	let before = try_many_gadt try_non_omega constrs in
+        if
+	  full_match_gadt constrs && not (should_extend ext constrs)
+        then
+	  before
+        else
+          (*
+            D = filter_extra pss is the default matrix
+            as it is included in pss, one can avoid
+            recursive calls on specialized matrices,
+            Essentially :
+           * D exhaustive => pss exhaustive
+           * D non-exhaustive => we have a non-filtered value
+           *)
+          let r =  exhaust_gadt ext (filter_extra pss) (n-1) in
+          match r with
+          | Rnone -> before
+          | 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) 
+              with
+      (* cannot occur, since constructors don't make a full signature *)
+              | Empty -> fatal_error "Parmatch.exhaust"
+    end
+
+let exhaust_gadt ext pss n = 
+  let ret = exhaust_gadt ext pss n in 
+  match ret with
+    Rnone -> Rnone
+  | Rsome lst ->
+      (* The following line is needed to compile stdlib/printf.ml *)
+      if lst = [] then Rsome (omegas n) else
+      let singletons = 
+	List.map 
+	  (function 
+	      [x] -> x
+	    | _ -> assert false)
+	  lst
+      in
+      Rsome [orify_many singletons]
+
 (*
    Another exhaustiveness check, enforcing variant typing.
    Note that it does not check exact exhaustiveness, but whether a
@@ -1015,12 +1172,12 @@ let rec pressure_variants tdefs = function
                 try_non_omega rem && ok
             | [] -> true
           in
-          if full_match (tdefs=None) constrs then
+          if full_match true (tdefs=None) constrs then
             try_non_omega constrs
           else if tdefs = None then
             pressure_variants None (filter_extra pss)
           else
-            let full = full_match true constrs in
+            let full = full_match true true constrs in
             let ok =
               if full then try_non_omega constrs
               else try_non_omega (filter_all q0 (mark_partial pss))
@@ -1394,7 +1551,6 @@ with
 | Empty -> lub p2 q
 
 and record_lubs l1 l2 =
-  let l1 = sort_fields l1 and l2 = sort_fields l2 in
   let rec lub_rec l1 l2 = match l1,l2 with
   | [],_ -> l2
   | _,[] -> l1
@@ -1516,7 +1672,120 @@ let check_partial_all v casel =
 (* Exhaustiveness check *)
 (************************)
 
-let do_check_partial loc casel pss = match pss with
+
+  let rec get_first f = 
+    function
+      | [] -> None
+      | x :: xs -> 
+	  match f x with 
+	  | None -> get_first f xs
+	  | x -> x
+
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = 
+    {ppat_desc = desc;
+     ppat_loc = Location.none}
+
+  let rec select : 'a list list -> 'a list list = 
+    function
+      | xs :: [] -> List.map (fun y -> [y]) xs
+      | (x::xs)::ys ->
+	  List.map
+	    (fun lst -> x :: lst)
+	    (select ys)
+	  @
+	    select (xs::ys)
+      | _ -> []
+
+  let name_counter = ref 0 
+  let fresh () = 
+    let current = !name_counter in 
+    name_counter := !name_counter + 1;
+    "#$%^@*@" ^ string_of_int current
+
+  let conv (typed: Typedtree.pattern) : 
+      Parsetree.pattern list * 
+      (string,Types.constructor_description) Hashtbl.t * 
+      (string,Types.label_description) Hashtbl.t
+      = 
+    let constrs = Hashtbl.create 0 in 
+    let labels = Hashtbl.create 0 in 
+    let rec loop pat = 
+      match pat.pat_desc with
+        Tpat_or (a,b,_) ->
+	  loop a @ loop b
+      | Tpat_any | Tpat_constant _ | Tpat_var _ ->
+	  [mkpat Ppat_any]
+      | Tpat_alias (p,_) -> loop p
+      | Tpat_tuple lst ->
+	  let results = select (List.map loop lst) in 
+	  List.map
+	    (fun lst -> mkpat (Ppat_tuple lst))
+	    results
+      | Tpat_construct (cstr,lst) ->
+	  let id = fresh () in 
+	  Hashtbl.add constrs id cstr;
+	  let results = select (List.map loop lst) in
+	  begin match lst with
+	    [] ->
+	      [mkpat (Ppat_construct(Longident.Lident id, None, false))]
+          | _ ->
+	      List.map 
+	        (fun lst ->
+		  let arg = 
+		    match lst with
+		      [] -> assert false
+		    | [x] -> Some x
+		    | _ -> Some (mkpat (Ppat_tuple lst))
+		  in
+		  mkpat (Ppat_construct(Longident.Lident id, arg, false)))
+	        results
+          end
+      | Tpat_variant(label,p_opt,row_desc) ->
+	  begin match p_opt with
+	  | None ->
+	      [mkpat (Ppat_variant(label, None))]
+	  | Some p ->
+	      let results = loop p in 
+	      List.map
+	        (fun p ->
+		  mkpat (Ppat_variant(label, Some p)))
+	        results
+          end
+      | Tpat_record subpatterns ->
+	  let pats = 
+	    select
+	      (List.map (fun (_,x) -> (loop x)) subpatterns)
+	  in
+	  let label_idents = 
+	    List.map 
+	      (fun (lbl,_) -> 
+	        let id = fresh () in 
+	        Hashtbl.add labels id lbl;
+	        Longident.Lident id)  
+	      subpatterns
+	  in 
+	  List.map
+	    (fun lst ->
+	      let lst = List.combine label_idents lst in
+	      mkpat (Ppat_record (lst, Open)))
+	    pats
+      | Tpat_array lst ->
+	  let results = select (List.map loop lst) in 
+	  List.map (fun lst -> mkpat (Ppat_array lst)) results
+      | Tpat_lazy p ->
+	  let results = loop p in 
+	  List.map (fun p -> mkpat (Ppat_lazy p)) results
+    in
+    let ps = loop typed in 
+    (ps, constrs, labels)
+end
+
+
+let do_check_partial ?pred exhaust loc casel pss = match pss with
 | [] ->
         (*
           This can occur
@@ -1534,31 +1803,48 @@ let do_check_partial loc casel pss = match pss with
 | ps::_  ->
     begin match exhaust None pss (List.length ps) with
     | Rnone -> Total
-    | Rsome [v] ->
-        let errmsg =
-          try
-            let buf = Buffer.create 16 in
-            let fmt = formatter_of_buffer buf in
-            top_pretty fmt v;
-            begin match check_partial_all v casel with
-            | None -> ()
-            | Some _ ->
-                  (* This is 'Some loc', where loc is the location of
-                     a possibly matching clause.
-                     Forget about loc, because printing two locations
-                     is a pain in the top-level *)
-                Buffer.add_string buf
-                  "\n(However, some guarded clause may match this value.)"
-            end ;
-            Buffer.contents buf
-          with _ ->
-            "" in
-        Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
-        Partial
+    | Rsome [u] ->
+	let v = 
+	  match pred with 
+	  | Some pred ->
+	      let (patterns,constrs,labels) = Conv.conv u in 
+	      get_first (pred constrs labels) patterns
+	  | None -> Some u
+	in
+	begin match v with
+	  None -> Total
+	| Some v ->
+            let errmsg =
+              try
+		let buf = Buffer.create 16 in
+		let fmt = formatter_of_buffer buf in
+		top_pretty fmt v;
+		begin match check_partial_all v casel with
+		| None -> ()
+		| Some _ ->
+                    (* This is 'Some loc', where loc is the location of
+                       a possibly matching clause.
+                       Forget about loc, because printing two locations
+                       is a pain in the top-level *)
+                    Buffer.add_string buf
+                      "\n(However, some guarded clause may match this value.)"
+		end ;
+		Buffer.contents buf
+              with _ ->
+		"" in
+            Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
+            Partial end
     | _ ->
         fatal_error "Parmatch.check_partial"
     end
 
+let do_check_partial_normal loc casel pss = 
+  do_check_partial exhaust loc casel pss
+
+let do_check_partial_gadt pred loc casel pss = 
+  do_check_partial ~pred exhaust_gadt loc casel pss
+
+
 
 (*****************)
 (* Fragile check *)
@@ -1576,6 +1862,7 @@ let extendable_path path =
   not
     (Path.same path Predef.path_bool ||
     Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
     Path.same path Predef.path_option)
 
 let rec collect_paths_from_pat r p = match p.pat_desc with
@@ -1607,7 +1894,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
       the type is extended.
 *)
 
-let do_check_fragile loc casel pss =
+let do_check_fragile_param exhaust loc casel pss =
   let exts =
     List.fold_left
       (fun r (p,_) -> collect_paths_from_pat r p)
@@ -1627,30 +1914,8 @@ let do_check_fragile loc casel pss =
             | Rsome _ -> ())
           exts
 
-
-(********************************)
-(* Exported exhustiveness check *)
-(********************************)
-
-(*
-   Fragile check is performed when required and
-   on exhaustive matches only.
-*)
-
-let check_partial loc casel =
-  if Warnings.is_active (Warnings.Partial_match "") then begin
-    let pss = initial_matrix casel in
-    let pss = get_mins le_pats pss in
-    let total = do_check_partial loc casel pss in
-    if
-      total = Total && Warnings.is_active (Warnings.Fragile_match "")
-    then begin
-      do_check_fragile loc casel pss
-    end ;
-    total
-  end else
-    Partial
-
+let do_check_fragile_normal = do_check_fragile_param exhaust
+let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
 
 (********************************)
 (* Exported unused clause check *)
@@ -1677,7 +1942,7 @@ let check_unused tdefs casel =
                         p.pat_loc Warnings.Unused_pat)
                     ps
               | Used -> ()
-            with e -> assert false
+            with Empty | Not_an_adt | Not_found | NoGuard -> assert false
             end ;
 
           if has_guard act then
@@ -1715,3 +1980,47 @@ let rec inactive pat = match pat with
 (* A `fluid' pattern is both irrefutable and inactive *)
 
 let fluid pat = irrefutable pat && inactive pat.pat_desc
+
+
+
+
+
+
+	    
+(********************************)
+(* Exported exhustiveness check *)
+(********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial_param do_check_partial do_check_fragile loc casel = 
+    if Warnings.is_active (Warnings.Partial_match "") then begin
+      let pss = initial_matrix casel in
+      let pss = get_mins le_pats pss in
+      let total = do_check_partial loc casel pss in
+      if
+	total = Total && Warnings.is_active (Warnings.Fragile_match "")
+      then begin
+	do_check_fragile loc casel pss
+      end ;
+      total
+    end else
+      Partial  
+
+let check_partial = 
+    check_partial_param 
+      do_check_partial_normal 
+      do_check_fragile_normal
+
+let check_partial_gadt pred loc casel =
+  (*ignores GADT constructors *)
+  let first_check = check_partial loc casel in
+  match first_check with
+  | Partial -> Partial
+  | Total -> 
+      (* checks for missing GADT constructors *)
+      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 7ef6a830..0cfaad7b 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -52,6 +52,11 @@ 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,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
 
 (* Irrefutability tests *)
diff --git a/typing/path.ml b/typing/path.ml
index 00955026..7dc821a1 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -37,12 +37,20 @@ let rec binding_time = function
   | Pdot(p, s, pos) -> binding_time p
   | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
 
-let rec name = function
+let kfalse x = false
+
+let rec name ?(paren=kfalse) = function
     Pident id -> Ident.name id
-  | Pdot(p, s, pos) -> name p ^ "." ^ s
-  | Papply(p1, p2) -> name p1 ^ "(" ^ name p2 ^ ")"
+  | Pdot(p, s, pos) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
 
 let rec head = function
     Pident id -> id
   | Pdot(p, s, pos) -> head p
   | Papply(p1, p2) -> assert false
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s, _) -> s
+  | Papply(_, p) -> last p
diff --git a/typing/path.mli b/typing/path.mli
index 96f3e983..bdcc6cca 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -25,5 +25,8 @@ val binding_time: t -> int
 
 val nopos: int
 
-val name: t -> string
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
 val head: t -> Ident.t
+
+val last: t -> string
diff --git a/typing/predef.ml b/typing/predef.ml
index 728eb572..432440b1 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -89,79 +89,98 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = None}
   and decl_bool =
     {type_params = [];
      type_arity = 0;
-     type_kind = Type_variant(["false", []; "true", []]);
+     type_kind = Type_variant(["false", [], None; "true", [], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = None}
   and decl_unit =
     {type_params = [];
      type_arity = 0;
-     type_kind = Type_variant(["()", []]);
+     type_kind = Type_variant(["()", [], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = 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_variance = [];
+     type_newtype_level = None}
   and decl_array =
     let tvar = newgenvar() in
     {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_variance = [true, true, true];
+     type_newtype_level = None}
   and decl_list =
     let tvar = newgenvar() in
     {type_params = [tvar];
      type_arity = 1;
      type_kind =
-       Type_variant(["[]", []; "::", [tvar; type_list tvar]]);
+     Type_variant(["[]", [], None; "::", [tvar; type_list tvar], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = [true, false, false]}
+     type_variance = [true, false, false];
+     type_newtype_level = None}
   and decl_format6 =
     {type_params = [
-       newgenvar(); newgenvar(); newgenvar();
-       newgenvar(); newgenvar(); newgenvar();
-     ];
+     newgenvar(); newgenvar(); newgenvar();
+     newgenvar(); newgenvar(); newgenvar();
+   ];
      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;
-     ]}
+     true, true, true; true, true, true;
+     true, true, true; true, true, true;
+     true, true, true; true, true, true;
+   ];
+     type_newtype_level = None}
   and decl_option =
     let tvar = newgenvar() in
     {type_params = [tvar];
      type_arity = 1;
-     type_kind = Type_variant(["None", []; "Some", [tvar]]);
+     type_kind = Type_variant(["None", [], None; "Some", [tvar], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = [true, false, false]}
+     type_variance = [true, false, false];
+     type_newtype_level = None}
   and decl_lazy_t =
     let tvar = newgenvar() in
     {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_variance = [true, false, false];
+     type_newtype_level = None}
   in
 
+  let add_exception id l = add_exception id { exn_args = l; exn_loc = Location.none } in
   add_exception ident_match_failure
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
   add_exception ident_out_of_memory [] (
diff --git a/typing/predef.mli b/typing/predef.mli
index b7bbb6f4..43e37965 100644
--- a/typing/predef.mli
+++ b/typing/predef.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/primitive.ml b/typing/primitive.ml
index 3d7ab5f7..a5c37659 100644
--- a/typing/primitive.ml
+++ b/typing/primitive.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/primitive.mli b/typing/primitive.mli
index 8446037f..0b48079a 100644
--- a/typing/primitive.mli
+++ b/typing/primitive.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 081e3008..84c0d194 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -109,6 +109,10 @@ let rec list_of_memo = function
   | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
   | Mlink rem -> list_of_memo !rem
 
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
 let visited = ref []
 let rec raw_type ppf ty =
   let ty = safe_repr [] ty in
@@ -119,7 +123,7 @@ let rec raw_type ppf ty =
   end
 and raw_type_list tl = raw_list raw_type tl
 and raw_type_desc ppf = function
-    Tvar -> fprintf ppf "Tvar"
+    Tvar name -> fprintf ppf "Tvar %a" print_name name
   | Tarrow(l,t1,t2,c) ->
       fprintf ppf "@[Tarrow(%s,@,%a,@,%a,@,%s)@]"
         l raw_type t1 raw_type t2
@@ -143,7 +147,7 @@ and raw_type_desc ppf = function
   | Tnil -> fprintf ppf "Tnil"
   | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
   | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
-  | Tunivar -> fprintf ppf "Tunivar"
+  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
   | Tpoly (t, tl) ->
       fprintf ppf "@[Tpoly(@,%a,@,%a)@]"
         raw_type t
@@ -183,32 +187,68 @@ let raw_type_expr ppf t =
   raw_type ppf t;
   visited := []
 
+let () = Btype.print_raw := raw_type_expr
+
 (* Print a type expression *)
 
 let names = ref ([] : (type_expr * string) list)
 let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
 
-let reset_names () = names := []; name_counter := 0
-
-let new_name () =
+let rec new_name () =
   let name =
     if !name_counter < 26
     then String.make 1 (Char.chr(97 + !name_counter))
     else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
            string_of_int(!name_counter / 26) in
   incr name_counter;
-  name
+  if List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  then new_name ()
+  else name
 
 let name_of_type t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
   try List.assq t !names with Not_found ->
-    let name = new_name () in
-    names := (t, name) :: !names;
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (string_of_int !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          new_name ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
     name
 
 let check_name_of_type t = ignore(name_of_type t)
 
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+
 let non_gen_mark sch ty =
-  if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
+  if sch && is_Tvar ty && ty.level <> generic_level then "_" else ""
 
 let print_name_of_type sch ppf t =
   fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
@@ -223,9 +263,13 @@ let add_delayed t =
 let is_aliased ty = List.memq (proxy ty) !aliased
 let add_alias ty =
   let px = proxy ty in
-  if not (is_aliased px) then aliased := px :: !aliased
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
 let aliasable ty =
-  match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true
+  match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
 
 let namable_row row =
   row.row_name <> None &&
@@ -243,7 +287,7 @@ let rec mark_loops_rec visited ty =
   if List.memq px visited && aliasable ty then add_alias px else
     let visited = px :: visited in
     match ty.desc with
-    | Tvar -> ()
+    | Tvar _ -> add_named_var ty
     | Tarrow(_, ty1, ty2, _) ->
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
@@ -288,7 +332,7 @@ let rec mark_loops_rec visited ty =
     | Tpoly (ty, tyl) ->
         List.iter (fun t -> add_alias t) tyl;
         mark_loops_rec visited ty
-    | Tunivar -> ()
+    | Tunivar _ -> add_named_var ty
 
 let mark_loops ty =
   normalize_type Env.empty ty;
@@ -320,7 +364,7 @@ let rec tree_of_typexp sch ty =
 
   let pr_typ () =
     match ty.desc with
-    | Tvar ->
+    | Tvar _ ->
         Otyp_var (is_non_gen sch ty, name_of_type ty)
     | Tarrow(l, ty1, ty2, _) ->
         let pr_arrow l ty1 ty2 =
@@ -377,26 +421,35 @@ let rec tree_of_typexp sch ty =
             Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
         end
     | Tobject (fi, nm) ->
-        tree_of_typobject sch fi nm
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
     | Tsubst ty ->
         tree_of_typexp sch ty
-    | Tlink _ | Tnil | Tfield _ ->
+    | Tlink _ ->
         fatal_error "Printtyp.tree_of_typexp"
     | Tpoly (ty, []) ->
         tree_of_typexp sch ty
     | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
         let tyl = List.map repr tyl in
-        (* let tyl = List.filter is_aliased tyl in *)
         if tyl = [] then tree_of_typexp sch ty else begin
           let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
           List.iter add_delayed tyl;
           let tl = List.map name_of_type tyl in
           let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
           delayed := old_delayed; tr
         end
-    | Tunivar ->
+    | Tunivar _ ->
         Otyp_var (false, name_of_type ty)
     | Tpackage (p, n, tyl) ->
+        let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in
         Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
   in
   if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
@@ -419,7 +472,7 @@ and tree_of_typlist sch tyl =
   List.map (tree_of_typexp sch) tyl
 
 and tree_of_typobject sch fi nm =
-  begin match !nm with
+  begin match nm with
   | None ->
       let pr_fields fi =
         let (fields, rest) = flatten_fields fi in
@@ -431,7 +484,7 @@ and tree_of_typobject sch fi nm =
                | _ -> l)
             fields [] in
         let sorted_fields =
-          Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in
+          List.sort (fun (n, _) (n', _) -> compare n n') present_fields in
         tree_of_typfields sch rest sorted_fields in
       let (fields, rest) = pr_fields fi in
       Otyp_object (fields, rest)
@@ -444,13 +497,13 @@ and tree_of_typobject sch fi nm =
   end
 
 and is_non_gen sch ty =
-    sch && ty.desc = Tvar && ty.level <> generic_level
+    sch && is_Tvar ty && ty.level <> generic_level
 
 and tree_of_typfields sch rest = function
   | [] ->
       let rest =
         match rest.desc with
-        | Tvar | Tunivar -> Some (is_non_gen sch rest)
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
         | Tconstr _ -> Some false
         | Tnil -> None
         | _ -> fatal_error "typfields (1)"
@@ -533,9 +586,12 @@ let rec tree_of_type_decl id decl =
   in
   begin match decl.type_kind with
   | Type_abstract -> ()
-  | Type_variant [] -> ()
   | Type_variant cstrs ->
-      List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
+      List.iter 
+	(fun (_, args,ret_type_opt) -> 
+	  List.iter mark_loops args;
+	  may mark_loops ret_type_opt)
+	cstrs
   | Type_record(l, rep) ->
       List.iter (fun (_, _, ty) -> mark_loops ty) l
   end;
@@ -550,13 +606,16 @@ let rec tree_of_type_decl id decl =
       match decl.type_kind with
         Type_abstract ->
           decl.type_manifest = None || decl.type_private = Private
-      | Type_variant _ | Type_record _ ->
+      | Type_record _ ->
           decl.type_private = Private
+      | Type_variant tll ->
+          decl.type_private = Private ||
+          List.exists (fun (_,_,ret) -> ret <> None) tll
     in
     let vari =
       List.map2
         (fun ty (co,cn,ct) ->
-          if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
+          if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
         decl.type_params decl.type_variance
     in
     (Ident.name id,
@@ -587,8 +646,20 @@ let rec tree_of_type_decl id decl =
   in
   (name, args, ty, priv, constraints)
 
-and tree_of_constructor (name, args) =
-  (name, tree_of_typlist false args)
+and tree_of_constructor (name, args, ret_type_opt) =
+  if ret_type_opt = None then (name, tree_of_typlist false args, None) else
+  let nm = !names in
+  names := [];
+  let ret = may_map (tree_of_typexp false) ret_type_opt in
+  let args = tree_of_typlist false args in
+  names := nm;
+  (name, args, ret)
+    
+
+and tree_of_constructor_ret =
+  function
+    | None -> None
+    | Some ret_type -> Some (tree_of_typexp false ret_type)
 
 and tree_of_label (name, mut, arg) =
   (name, mut = Mutable, tree_of_typexp false arg)
@@ -602,8 +673,8 @@ let type_declaration id ppf decl =
 (* Print an exception declaration *)
 
 let tree_of_exception_declaration id decl =
-  reset_and_mark_loops_list decl;
-  let tyl = tree_of_typlist false decl in
+  reset_and_mark_loops_list decl.exn_args;
+  let tyl = tree_of_typlist false decl.exn_args in
   Osig_exception (Ident.name id, tyl)
 
 let exception_declaration id ppf decl =
@@ -632,16 +703,18 @@ let class_var sch ppf l (m, t) =
 
 let method_type (_, kind, ty) =
   match field_kind_repr kind, repr ty with
-    Fpresent, {desc=Tpoly(ty, _)} -> ty
-  | _       , ty                  -> ty
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
 
 let tree_of_metho sch concrete csil (lab, kind, ty) =
   if lab <> dummy_method then begin
     let kind = field_kind_repr kind in
     let priv = kind <> Fpresent in
     let virt = not (Concr.mem lab concrete) in
-    let ty = method_type (lab, kind, ty) in
-    Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
+    let (ty, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
   end
   else csil
 
@@ -649,7 +722,7 @@ let rec prepare_class_type params = function
   | Tcty_constr (p, tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq (proxy sty) !visited_objects
-      || List.exists (fun ty -> (repr ty).desc <> Tvar) params
+      || not (List.for_all is_Tvar params)
       || List.exists (deep_occur sty) tyl
       then prepare_class_type params cty
       else List.iter mark_loops tyl
@@ -662,7 +735,7 @@ let rec prepare_class_type params = function
       let (fields, _) =
         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
       in
-      List.iter (fun met -> mark_loops (method_type met)) fields;
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
       Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
   | Tcty_fun (_, ty, cty) ->
       mark_loops ty;
@@ -673,7 +746,7 @@ let rec tree_of_class_type sch params =
   | Tcty_constr (p', tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq (proxy sty) !visited_objects
-      || List.exists (fun ty -> (repr ty).desc <> Tvar) params
+      || not (List.for_all is_Tvar params)
       then
         tree_of_class_type sch params cty
       else
@@ -730,7 +803,7 @@ let tree_of_class_param param variance =
   (match tree_of_typexp true param with
     Otyp_var (_, s) -> s
   | _ -> "?"),
-  if (repr param).desc = Tvar then (true, true) else variance
+  if is_Tvar (repr param) then (true, true) else variance
 
 let tree_of_class_params params =
   let tyl = tree_of_typlist true params in
@@ -864,6 +937,8 @@ let rec trace fst txt ppf = function
   | _ -> ()
 
 let rec filter_trace = 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'
@@ -877,7 +952,7 @@ let hide_variant_name t =
   | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
       newty2 t.level
         (Tvariant {(row_repr row) with row_name = None;
-                   row_more = newty2 (row_more row).level Tvar})
+                   row_more = newvar2 (row_more row).level})
   | _ -> t
 
 let prepare_expansion (t, t') =
@@ -899,11 +974,10 @@ let print_tags ppf fields =
 
 let has_explanation unif t3 t4 =
   match t3.desc, t4.desc with
-    Tfield _, _ | _, Tfield _
-  | Tunivar, Tvar | Tvar, Tunivar
+    Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
+  | _, Tvar _ | Tvar _, _
   | Tvariant _, Tvariant _ -> true
-  | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
-      unif && min t3.level t4.level < Path.binding_time p
+  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
   | _ -> false
 
 let rec mismatch unif = function
@@ -918,31 +992,40 @@ let rec mismatch unif = function
 
 let explanation unif t3 t4 ppf =
   match t3.desc, t4.desc with
-  | Tfield _, Tvar | Tvar, Tfield _ ->
+  | Tfield _, Tvar _ | Tvar _, Tfield _ ->
       fprintf ppf "@,Self type cannot escape its class"
-  | Tconstr (p, _, _), Tvar
+  | Tconstr (p, tl, _), Tvar _
     when unif && t4.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
         path p
-  | Tvar, Tconstr (p, _, _)
+  | Tvar _, Tconstr (p, tl, _)
     when unif && t3.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
         path p
-  | Tvar, Tunivar | Tunivar, Tvar ->
+  | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
       fprintf ppf "@,The universal variable %a would escape its scope"
-        type_expr (if t3.desc = Tunivar then t3 else t4)
+        type_expr (if is_Tunivar t3 then t3 else t4)
+  | Tvar _, _ | _, Tvar _ ->
+      let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in
+      if occur_in Env.empty t t' then
+        fprintf ppf "@,@[The type variable %a occurs inside@ %a@]"
+          type_expr t type_expr t'
+      else
+        fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]"
+          type_expr t'
+          "it would escape the scope of its equation"
   | Tfield (lab, _, _, _), _
   | _, Tfield (lab, _, _, _) when lab = dummy_method ->
       fprintf ppf
         "@,Self type cannot be unified with a closed object type"
-  | Tfield (l, _, _, _), Tfield (l', _, _, _) when l = l' ->
+  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' ->
       fprintf ppf "@,Types for method %s are incompatible" l
-  | _, Tfield (l, _, _, _) ->
+  | (Tnil|Tconstr _), Tfield (l, _, _, _) ->
       fprintf ppf
         "@,@[The first object type has no method %s@]" l
-  | Tfield (l, _, _, _), _ ->
+  | Tfield (l, _, _, _), (Tnil|Tconstr _) ->
       fprintf ppf
         "@,@[The second object type has no method %s@]" l
   | Tvariant row1, Tvariant row2 ->
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index 5e3402ff..5417ebf4 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/stypes.ml b/typing/stypes.ml
index 4d1166fe..1d2c0efd 100644
--- a/typing/stypes.ml
+++ b/typing/stypes.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/stypes.mli b/typing/stypes.mli
index 32f92c1d..02cccd80 100644
--- a/typing/stypes.mli
+++ b/typing/stypes.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/subst.ml b/typing/subst.ml
index 6aa27660..4a84a4e2 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -71,18 +71,20 @@ let new_id = ref (-1)
 let reset_for_saving () = new_id := -1
 
 let newpersty desc =
-  decr new_id; { desc = desc; level = generic_level; id = !new_id }
+  decr new_id;
+  { desc = desc; level = generic_level; id = !new_id }
 
 (* Similar to [Ctype.nondep_type_rec]. *)
 let rec typexp s ty =
   let ty = repr ty in
   match ty.desc with
-    Tvar | Tunivar ->
+    Tvar _ | Tunivar _ as desc ->
       if s.for_saving || ty.id < 0 then
         let ty' =
-          if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
+          if s.for_saving then newpersty desc
+          else newty2 ty.level desc
         in
-        save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
+        save_desc ty desc; ty.desc <- Tsubst ty'; ty'
       else ty
   | Tsubst ty ->
       ty
@@ -94,7 +96,7 @@ let rec typexp s ty =
     let desc = ty.desc in
     save_desc ty desc;
     (* Make a stub *)
-    let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
     ty.desc <- Tsubst ty';
     ty'.desc <-
       begin match desc with
@@ -126,11 +128,11 @@ let rec typexp s ty =
               let more' =
                 match more.desc with
                   Tsubst ty -> ty
-                | Tconstr _ -> typexp s more
-                | Tunivar | Tvar ->
+                | Tconstr _ | Tnil -> typexp s more
+                | Tunivar _ | Tvar _ ->
                     save_desc more more.desc;
                     if s.for_saving then newpersty more.desc else
-                    if dup && more.desc <> Tunivar then newgenvar () else more
+                    if dup && is_Tvar more then newgenty more.desc else more
                 | _ -> assert false
               in
               (* Register new type first for recursion *)
@@ -167,22 +169,26 @@ let type_declaration s decl =
         begin match decl.type_kind with
           Type_abstract -> Type_abstract
         | Type_variant cstrs ->
-            Type_variant(
-              List.map (fun (n, args) -> (n, List.map (typexp s) args))
-                       cstrs)
+            Type_variant
+              (List.map
+                 (fun (n, args, ret_type) -> 
+		   (n, List.map (typexp s) args, may_map (typexp s) ret_type))
+                 cstrs)
         | Type_record(lbls, rep) ->
-            Type_record(
-              List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
-                       lbls,
-              rep)
+            Type_record
+              (List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls,
+               rep)
         end;
       type_manifest =
-        begin match decl.type_manifest with
-          None -> None
-        | Some ty -> Some(typexp s ty)
+        begin 
+	  match decl.type_manifest with
+            None -> None
+          | Some ty -> Some(typexp s ty)
         end;
       type_private = decl.type_private;
       type_variance = decl.type_variance;
+      type_newtype_level = None;
+      type_loc = if s.for_saving then Location.none else decl.type_loc;
     }
   in
   cleanup_types ();
@@ -241,10 +247,14 @@ let class_type s cty =
 
 let value_description s descr =
   { val_type = type_expr s descr.val_type;
-    val_kind = descr.val_kind }
-
-let exception_declaration s tyl =
-  List.map (type_expr s) tyl
+    val_kind = descr.val_kind;
+    val_loc = if s.for_saving then Location.none else descr.val_loc;
+   }
+
+let exception_declaration s descr =
+  { exn_args = List.map (type_expr s) descr.exn_args;
+    exn_loc = if s.for_saving then Location.none else descr.exn_loc;
+   }
 
 let rec rename_bound_idents s idents = function
     [] -> (List.rev idents, s)
diff --git a/typing/subst.mli b/typing/subst.mli
index c861a57b..cf977885 100644
--- a/typing/subst.mli
+++ b/typing/subst.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c81e8fe8..5610c3e9 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -192,21 +192,22 @@ let rc node =
 
 
 (* Enter a value in the method environment only *)
-let enter_met_env lab kind ty val_env met_env par_env =
+let enter_met_env ?check loc lab kind ty val_env met_env par_env =
   let (id, val_env) =
-    Env.enter_value lab {val_type = ty; val_kind = Val_unbound} val_env
+    Env.enter_value lab {val_type = ty; val_kind = Val_unbound; val_loc = loc} val_env
   in
   (id, val_env,
-   Env.add_value id {val_type = ty; val_kind = kind} met_env,
-   Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
+   Env.add_value ?check id {val_type = ty; val_kind = kind; val_loc = loc} met_env,
+   Env.add_value id {val_type = ty; val_kind = Val_unbound; val_loc = loc} par_env)
 
 (* Enter an instance variable in the environment *)
 let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
+  let instance = Ctype.instance val_env in
   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)));
-      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+      Ctype.unify val_env (instance ty) (instance ty');
       (if not inh then Some id else None),
       (if virt' = Concrete then virt' else virt)
     with
@@ -217,7 +218,7 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
   let (id, _, _, _) as result =
     match id with Some id -> (id, val_env, met_env, par_env)
     | None ->
-        enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
   in
   vars := Vars.add lab (id, mut, virt, ty) !vars;
   result
@@ -461,7 +462,8 @@ let rec class_field cl_num self_type meths vars
             (val_env, met_env, par_env)
         | Some name ->
             let (id, val_env, met_env, par_env) =
-              enter_met_env name (Val_anc (inh_meths, cl_num)) self_type
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
                 val_env met_env par_env
             in
             (val_env, met_env, par_env)
@@ -532,7 +534,7 @@ let rec class_field cl_num self_type meths vars
                 (Typetexp.transl_simple_type val_env false sty) ty
           end;
           begin match (Ctype.repr ty).desc with
-            Tvar ->
+            Tvar _ ->
               let ty' = Ctype.newvar () in
               Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
               Ctype.unify val_env (type_approx val_env sbody) ty'
@@ -553,7 +555,7 @@ let rec class_field cl_num self_type meths vars
       let field =
         lazy begin
           let meth_type =
-            Ctype.newty (Tarrow("", self_type, Ctype.instance ty, Cok)) in
+            Btype.newgenty (Tarrow("", self_type, ty, Cok)) in
           Ctype.raise_nongen_level ();
           vars := vars_local;
           let texp = type_expect met_env meth_expr meth_type in
@@ -567,36 +569,6 @@ let rec class_field cl_num self_type meths vars
       type_constraint val_env sty sty' loc;
       (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher)
 
-  | Pcf_let (rec_flag, sdefs, loc) ->
-      let (defs, val_env) =
-        try
-          Typecore.type_let val_env rec_flag sdefs None
-        with Ctype.Unify [(ty, _)] ->
-          raise(Error(loc, Make_nongen_seltype ty))
-      in
-      let (vals, met_env, par_env) =
-        List.fold_right
-          (fun id (vals, met_env, par_env) ->
-             let expr =
-               Typecore.type_exp val_env
-                 {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
-                  pexp_loc = Location.none}
-             in
-             let desc =
-               {val_type = expr.exp_type;
-                val_kind = Val_ivar (Immutable, cl_num)}
-             in
-             let id' = Ident.create (Ident.name id) in
-             ((id', expr)
-              :: vals,
-              Env.add_value id' desc met_env,
-              Env.add_value id' desc par_env))
-          (let_bound_idents defs)
-          ([], met_env, par_env)
-      in
-      (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
-       concr_meths, warn_vals, inher)
-
   | Pcf_init expr ->
       let expr = make_method cl_num expr in
       let vars_local = !vars in
@@ -605,7 +577,8 @@ let rec class_field cl_num self_type meths vars
           Ctype.raise_nongen_level ();
           let meth_type =
             Ctype.newty
-              (Tarrow ("", self_type, Ctype.instance Predef.type_unit, Cok)) in
+              (Tarrow ("", self_type,
+                       Ctype.instance_def Predef.type_unit, Cok)) in
           vars := vars_local;
           let texp = type_expect met_env expr meth_type in
           Ctype.end_def ();
@@ -800,10 +773,16 @@ and class_expr cl_num val_env met_env scl =
       let pv =
         List.map
           (function (id, id', ty) ->
+            let path = Pident id' in
+            let vd = Env.find_value path val_env' (* do not mark the value as being used *) in
             (id,
-             Typecore.type_exp val_env'
-               {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
-                pexp_loc = Location.none}))
+             {
+              exp_desc = Texp_ident(path, vd);
+              exp_loc = Location.none;
+              exp_type = Ctype.instance val_env' vd.val_type;
+              exp_env = val_env'
+             })
+          )
           pv
       in
       let rec not_function = function
@@ -816,7 +795,8 @@ and class_expr cl_num val_env met_env scl =
            {exp_desc = Texp_constant (Asttypes.Const_int 1);
             exp_loc = Location.none;
             exp_type = Ctype.none;
-            exp_env = Env.empty }] in
+            exp_env = Env.empty }] 
+      in
       Ctype.raise_nongen_level ();
       let cl = class_expr cl_num val_env' met_env scl' in
       Ctype.end_def ();
@@ -825,7 +805,8 @@ and class_expr cl_num val_env met_env scl =
           Warnings.Unerasable_optional_argument;
       rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
           cl_loc = scl.pcl_loc;
-          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_type = Tcty_fun
+            (l, Ctype.instance_def pat.pat_type, cl.cl_type);
           cl_env = val_env}
   | Pcl_apply (scl', sargs) ->
       let cl = class_expr cl_num val_env met_env scl' in
@@ -861,7 +842,8 @@ and class_expr cl_num val_env met_env scl =
                 | _, (l', sarg0)::more_sargs ->
                     if l <> l' && l' <> "" then
                       raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
-                    else ([], more_sargs, Some(type_argument val_env sarg0 ty))
+                    else ([], more_sargs,
+                          Some (type_argument val_env sarg0 ty ty))
                 | _ ->
                     assert false
               end else try
@@ -877,10 +859,10 @@ and class_expr cl_num val_env met_env scl =
                 in
                 sargs, more_sargs,
                 if Btype.is_optional l' || not (Btype.is_optional l) then
-                  Some (type_argument val_env sarg0 ty)
+                  Some (type_argument val_env sarg0 ty ty)
                 else
-                  let arg = type_argument val_env
-                      sarg0 (extract_option_type val_env ty) in
+                  let ty0 = extract_option_type val_env ty in
+                  let arg = type_argument val_env sarg0 ty0 ty0 in
                   Some (option_some arg)
               with Not_found ->
                 sargs, more_sargs,
@@ -925,17 +907,24 @@ and class_expr cl_num val_env met_env scl =
       let (vals, met_env) =
         List.fold_right
           (fun id (vals, met_env) ->
+             let path = Pident id in
+             let vd = Env.find_value path val_env in (* do not mark the value as used *)
              Ctype.begin_def ();
              let expr =
-               Typecore.type_exp val_env
-                 {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
-                  pexp_loc = Location.none}
+               {
+                exp_desc = Texp_ident(path, vd);
+                exp_loc = Location.none;
+                exp_type = Ctype.instance val_env vd.val_type;
+                exp_env = val_env;
+               }
              in
              Ctype.end_def ();
              Ctype.generalize expr.exp_type;
              let desc =
                {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
-                                                               cl_num)}
+                                                               cl_num);
+                val_loc = vd.val_loc;
+               }
              in
              let id' = Ident.create (Ident.name id) in
              ((id', expr)
@@ -984,7 +973,7 @@ let rec approx_declaration cl =
   match cl.pcl_desc with
     Pcl_fun (l, _, _, cl) ->
       let arg =
-        if Btype.is_optional l then Ctype.instance var_option
+        if Btype.is_optional l then Ctype.instance_def var_option
         else Ctype.newvar () in
       Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
   | Pcl_let (_, _, cl) ->
@@ -997,14 +986,14 @@ let rec approx_description ct =
   match ct.pcty_desc with
     Pcty_fun (l, _, ct) ->
       let arg =
-        if Btype.is_optional l then Ctype.instance var_option
+        if Btype.is_optional l then Ctype.instance_def var_option
         else Ctype.newvar () in
       Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
   | _ -> Ctype.newvar ()
 
 (*******************************)
 
-let temp_abbrev env id arity =
+let temp_abbrev loc env id arity =
   let params = ref [] in
   for i = 1 to arity do
     params := Ctype.newvar () :: !params
@@ -1017,7 +1006,10 @@ let temp_abbrev 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 = List.map (fun _ -> true, true, true) !params;
+       type_newtype_level = None;
+       type_loc = loc;
+      }
       env
   in
   (!params, ty, env)
@@ -1026,8 +1018,8 @@ let rec 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
-  let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in
-  let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in
 
   (* Temporary type for the class constructor *)
   let constr_type = approx cl.pci_expr in
@@ -1103,6 +1095,7 @@ let class_infos define_class kind
   Ctype.end_def ();
 
   let sty = Ctype.self_type typ in
+  ignore (Ctype.object_fields sty);
 
   (* Generalize the row variable *)
   let rv = Ctype.row_variable sty in
@@ -1160,7 +1153,7 @@ let class_infos define_class kind
   begin try
     Ctype.unify env
       (constructor_type constr obj_type)
-      (Ctype.instance constr_type)
+      (Ctype.instance env constr_type)
   with Ctype.Unify trace ->
     raise(Error(cl.pci_loc,
                 Constructor_type_mismatch (cl.pci_name, trace)))
@@ -1220,7 +1213,7 @@ let class_infos define_class kind
      cty_new =
        match cl.pci_virt with
          Virtual  -> None
-       | Concrete -> Some (Ctype.instance constr_type)}
+       | Concrete -> Some (Ctype.instance env constr_type)}
   in
   let obj_abbr =
     {type_params = obj_params;
@@ -1228,7 +1221,9 @@ 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 _ -> true, true, true) obj_params;
+     type_newtype_level = None;
+     type_loc = cl.pci_loc}
   in
   let (cl_params, cl_ty) =
     Ctype.instance_parameterized_type params (Ctype.self_type typ)
@@ -1241,7 +1236,9 @@ 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 _ -> true, true, true) cl_params;
+     type_newtype_level = None;
+     type_loc = cl.pci_loc}
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
     arity, pub_meths, List.rev !coercion_locs, expr) :: res,
@@ -1404,8 +1401,10 @@ let rec unify_parents env ty cl =
       begin try
         let decl = Env.find_class p env in
         let _, body = Ctype.find_cltype_for_path env decl.cty_path in
-        Ctype.unify env ty (Ctype.instance body)
-      with exn -> assert (exn = Not_found)
+        Ctype.unify env ty (Ctype.instance env body)
+      with
+        Not_found -> ()
+      | exn -> assert false
       end
   | Tclass_structure st -> unify_parents_struct env ty st
   | Tclass_fun (_, _, cl, _)
@@ -1603,3 +1602,4 @@ let report_error ppf = function
         "instance variable"
   | No_overriding (kind, name) ->
       fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+	
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index e360ba4e..9841ed40 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 48611548..a4aa5179 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -56,6 +56,11 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Recursive_local_constraint of (type_expr * type_expr) list
+  | Unexpected_existential
 
 exception Error of Location.t * error
 
@@ -70,6 +75,10 @@ let type_module =
 let type_open =
   ref (fun _ -> assert false)
 
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
 
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
@@ -92,17 +101,116 @@ let rp node =
   node
 ;;
 
+(* Upper approximation of free identifiers on the parse tree *)
+
+let iter_expression f e =
+
+  let rec expr e =
+    f e;
+    match e.pexp_desc with
+    | Pexp_ident _
+    | Pexp_assertfalse
+    | Pexp_new _
+    | Pexp_constant _ -> ()
+    | Pexp_function (_, eo, pel) ->
+        may expr eo; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
+    | Pexp_let (_, pel, e)
+    | Pexp_match (e, pel)
+    | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_array el
+    | Pexp_tuple el -> List.iter expr el
+    | Pexp_construct (_, eo, _)
+    | Pexp_variant (_, eo) -> may expr eo
+    | Pexp_record (iel, eo) ->
+        may expr eo; List.iter (fun (_, e) -> expr e) iel
+    | Pexp_open (_, e)
+    | Pexp_newtype (_, e)
+    | Pexp_poly (e, _)
+    | Pexp_lazy e
+    | Pexp_assert e
+    | Pexp_setinstvar (_, e)
+    | Pexp_send (e, _)
+    | Pexp_constraint (e, _, _)
+    | Pexp_field (e, _) -> expr e
+    | Pexp_when (e1, e2)
+    | Pexp_while (e1, e2)
+    | Pexp_sequence (e1, e2)
+    | Pexp_setfield (e1, _, e2) -> expr e1; expr e2
+    | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo
+    | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3
+    | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel
+    | Pexp_letmodule (_, me, e) -> expr e; module_expr me
+    | Pexp_object (_, cs) -> List.iter class_field cs
+    | Pexp_pack me -> module_expr me
+
+  and module_expr me =
+    match me.pmod_desc with
+    | Pmod_ident _ -> ()
+    | Pmod_structure str -> List.iter structure_item str
+    | Pmod_constraint (me, _)
+    | Pmod_functor (_, _, me) -> module_expr me
+    | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
+    | Pmod_unpack e -> expr e
+
+  and structure_item str =
+    match str.pstr_desc with
+    | Pstr_eval e -> expr e
+    | Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel
+    | Pstr_primitive _
+    | Pstr_type _
+    | Pstr_exception _
+    | Pstr_modtype _
+    | Pstr_open _
+    | Pstr_class_type _
+    | Pstr_exn_rebind _ -> ()
+    | Pstr_include me
+    | Pstr_module (_, me) -> module_expr me
+    | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
+    | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
+
+  and class_expr ce =
+    match ce.pcl_desc with
+    | Pcl_constr _ -> ()
+    | Pcl_structure (_, cfl) -> List.iter class_field cfl
+    | Pcl_fun (_, eo, _,  ce) -> may expr eo; class_expr ce
+    | Pcl_apply (ce, lel) ->
+        class_expr ce; List.iter (fun (_, e) -> expr e) lel
+    | Pcl_let (_, pel, ce) ->
+        List.iter (fun (_, e) -> expr e) pel; class_expr ce
+    | Pcl_constraint (ce, _) -> class_expr ce
+
+  and class_field = function
+    | Pcf_inher (_, ce, _) -> class_expr ce
+    | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> ()
+    | Pcf_val (_,_,_, e, _) | Pcf_meth (_,_,_, e, _) -> expr e
+    | Pcf_init e -> expr e
+
+  in
+  expr e
+
+
+let all_idents el =
+  let idents = Hashtbl.create 8 in
+  let f = function
+    | {pexp_desc=Pexp_ident (Longident.Lident id); _} ->
+        Hashtbl.replace idents id ()
+    | _ -> ()
+  in
+  List.iter (iter_expression f) el;
+  Hashtbl.fold (fun x () rest -> x :: rest) idents []
+
 
 (* Typing of constants *)
 
 let type_constant = function
-    Const_int _ -> instance Predef.type_int
-  | Const_char _ -> instance Predef.type_char
-  | Const_string _ -> instance Predef.type_string
-  | Const_float _ -> instance Predef.type_float
-  | Const_int32 _ -> instance Predef.type_int32
-  | Const_int64 _ -> instance Predef.type_int64
-  | Const_nativeint _ -> instance Predef.type_nativeint
+    Const_int _ -> instance_def Predef.type_int
+  | Const_char _ -> instance_def Predef.type_char
+  | Const_string _ -> instance_def Predef.type_string
+  | Const_float _ -> instance_def Predef.type_float
+  | Const_int32 _ -> instance_def Predef.type_int32
+  | Const_int64 _ -> instance_def Predef.type_int64
+  | Const_nativeint _ -> instance_def Predef.type_nativeint
 
 (* Specific version of type_option, using newty rather than newgenty *)
 
@@ -125,7 +233,7 @@ let extract_option_type env ty =
   | _ -> assert false
 
 let rec extract_label_names sexp env ty =
-  let ty = repr ty in
+  let ty = expand_head env ty in
   match ty.desc with
   | Tconstr (path, _, _) ->
       let td = Env.find_type path env in
@@ -141,15 +249,55 @@ let rec extract_label_names sexp env ty =
 
 (* Typing of patterns *)
 
-(* Creating new conjunctive types is not allowed when typing patterns *)
-let unify_pat env pat expected_ty =
+(* unification inside type_pat*)
+let unify_pat_types loc env ty ty' =
   try
-    unify env pat.pat_type expected_ty
+    unify env ty ty'
   with
     Unify trace ->
-      raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
+      raise(Error(loc, Pattern_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(Error(loc, Expr_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let newtype_level = ref None
+let get_newtype_level () =
+  match !newtype_level with
+    Some y -> y
+  | None -> assert false
+
+let unify_pat_types_gadt loc env ty ty' =
+  let newtype_level =
+    match !newtype_level with
+    | None -> assert false
+    | Some x -> x
+  in
+  try
+    unify_gadt ~newtype_level env ty ty'
+  with
+    Unify trace ->
+      raise(Error(loc, Pattern_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+  | Unification_recursive_abbrev trace ->
+      raise(Error(loc, Recursive_local_constraint trace))
+
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+let unify_pat env pat expected_ty =
+  unify_pat_types pat.pat_loc env pat.pat_type expected_ty
 
 (* make all Reither present in open variants *)
 let finalize_variant pat =
@@ -193,29 +341,38 @@ let has_variants p =
 
 
 (* pattern environment *)
-let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
+let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t * bool (* as-variable *)) list)
 let pattern_force = ref ([] : (unit -> unit) list)
 let pattern_scope = ref (None : Annot.ident option);;
-let reset_pattern scope =
+let allow_modules = ref false
+let module_variables = ref ([] : (string * Location.t) list)
+let reset_pattern scope allow =
   pattern_variables := [];
   pattern_force := [];
   pattern_scope := scope;
+  allow_modules := allow;
+  module_variables := [];
 ;;
 
-let enter_variable loc name ty =
-  if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
+  if List.exists (fun (id, _, _, _) -> Ident.name id = name) !pattern_variables
   then raise(Error(loc, Multiply_bound_variable name));
   let id = Ident.create name in
-  pattern_variables := (id, ty, loc) :: !pattern_variables;
-  begin match !pattern_scope with
-  | None -> ()
-  | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
+  pattern_variables := (id, ty, 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));
+    module_variables := (name, loc) :: !module_variables
+  end else begin
+    match !pattern_scope with
+    | None -> ()
+    | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
   end;
   id
 
 let sort_pattern_variables vs =
   List.sort
-    (fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
+    (fun (x,_,_,_) (y,_,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
     vs
 
 let enter_orpat_variables loc env  p1_vs p2_vs =
@@ -225,7 +382,7 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   and p2_vs = sort_pattern_variables p2_vs in
 
   let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
-      | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
+      | (x1,t1,l1,a1)::rem1, (x2,t2,l2,a2)::rem2 when Ident.equal x1 x2 ->
           if x1==x2 then
             unify_vars rem1 rem2
           else begin
@@ -234,13 +391,13 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
             with
             | Unify trace ->
                 raise(Error(loc, Pattern_type_clash(trace)))
-            end ;
+            end;
           (x2,x1)::unify_vars rem1 rem2
           end
       | [],[] -> []
-      | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
-      | [],(x,_,_)::_  -> raise (Error (loc, Orpat_vars x))
-      | (x,_,_)::_, (y,_,_)::_ ->
+      | (x,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
+      | [],(x,_,_,_)::_  -> raise (Error (loc, Orpat_vars x))
+      | (x,_,_,_)::_, (y,_,_,_)::_ ->
           let min_var =
             if Ident.name x < Ident.name y then x
             else y in
@@ -254,7 +411,8 @@ let rec build_as_type env p =
       let tyl = List.map (build_as_type env) pl in
       newty (Ttuple tyl)
   | Tpat_construct(cstr, pl) ->
-      if cstr.cstr_private = Private then p.pat_type else
+      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
       let ty_args, ty_res = instance_constructor cstr in
       List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
@@ -343,23 +501,41 @@ let build_or_pat env loc lid =
           (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0);
                             pat_loc=gloc; pat_env=env; pat_type=ty})
           pat pats in
-      rp { r with pat_loc = loc }
+      (rp { r with pat_loc = loc },ty)
+
+(* Records *)
 
 let rec find_record_qual = function
   | [] -> None
   | (Longident.Ldot (modname, _), _) :: _ -> Some modname
   | _ :: rest -> find_record_qual rest
 
-let type_label_a_list type_lid_a lid_a_list =
-  match find_record_qual lid_a_list with
-  | None -> List.map type_lid_a lid_a_list
-  | Some modname ->
-      List.map
-        (function
-         | (Longident.Lident id), sarg ->
-              type_lid_a (Longident.Ldot (modname, id), sarg)
-         | lid_a -> type_lid_a lid_a)
-        lid_a_list
+let type_label_a_list ?labels env loc type_lbl_a lid_a_list =
+  let record_qual = find_record_qual lid_a_list in
+  let lbl_a_list =
+    List.map
+      (fun (lid, a) ->
+        match lid, labels, record_qual with
+          Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
+            Hashtbl.find labels s, a
+        | Longident.Lident s, _, Some modname ->
+            Typetexp.find_label env loc (Longident.Ldot (modname, s)), a
+        | _ ->
+            Typetexp.find_label env loc lid, a)
+      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)
+      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) *)
@@ -389,70 +565,114 @@ let check_recordpat_labels loc lbl_pat_list closed =
         end
       end
 
+(* unification of a type with a tconstr with
+   freshly created arguments *)
+let unify_head_only loc env ty constr =
+  let (_, ty_res) = instance_constructor constr in
+  match (repr ty_res).desc with
+  | Tconstr(p,args,m) ->
+      ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
+      enforce_constraints env ty_res;
+      unify_pat_types loc env ty ty_res
+  | _ -> assert false
+
 (* Typing of patterns *)
 
-let rec type_pat env sp =
+(* type_pat does not generate local constraints inside or patterns *)
+type type_pat_mode =
+  | Normal
+  | Inside_or
+
+(* type_pat propagates the expected type as well as maps for
+   constructors and labels.
+   Unification may update the typing environment. *)
+let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
+  let type_pat ?(mode=mode) ?(env=env) =
+    type_pat ~constrs ~labels ~no_existentials ~mode ~env in
   let loc = sp.ppat_loc in
   match sp.ppat_desc with
     Ppat_any ->
       rp {
         pat_desc = Tpat_any;
         pat_loc = loc;
-        pat_type = newvar();
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_var name ->
-      let ty = newvar() in
-      let id = enter_variable loc name ty in
+      let id = enter_variable loc name expected_ty in
+      rp {
+        pat_desc = Tpat_var id;
+        pat_loc = loc;
+        pat_type = expected_ty;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      let id = enter_variable loc name expected_ty ~is_module:true in
       rp {
         pat_desc = Tpat_var id;
         pat_loc = loc;
-        pat_type = ty;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc},
                     ({ptyp_desc=Ptyp_poly _} as sty)) ->
       (* explicitly polymorphic type *)
-      let ty, force = Typetexp.transl_simple_type_delayed env sty in
+      let ty, force = Typetexp.transl_simple_type_delayed !env sty in
+      unify_pat_types loc !env ty expected_ty;
       pattern_force := force :: !pattern_force;
       begin match ty.desc with
       | Tpoly (body, tyl) ->
           begin_def ();
-          let _, ty' = instance_poly false tyl body in
+          let _, ty' = instance_poly ~keep_names:true false tyl body in
           end_def ();
           generalize ty';
           let id = enter_variable loc name ty' in
           rp { pat_desc = Tpat_var id;
                pat_loc = loc;
                pat_type = ty;
-               pat_env = env }
+               pat_env = !env }
       | _ -> assert false
       end
   | Ppat_alias(sq, name) ->
-      let q = type_pat env sq in
+      let q = type_pat sq expected_ty in
       begin_def ();
-      let ty_var = build_as_type env q in
+      let ty_var = build_as_type !env q in
       end_def ();
       generalize ty_var;
-      let id = enter_variable loc name ty_var in
+      let id = enter_variable ~is_as_variable:true loc name ty_var in
       rp {
         pat_desc = Tpat_alias(q, id);
         pat_loc = loc;
         pat_type = q.pat_type;
-        pat_env = env }
+        pat_env = !env }
   | Ppat_constant cst ->
+      unify_pat_types loc !env (type_constant cst) expected_ty;
       rp {
         pat_desc = Tpat_constant cst;
         pat_loc = loc;
-        pat_type = type_constant cst;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_tuple spl ->
-      let pl = List.map (type_pat env) spl in
+      let spl_ann = List.map (fun p -> (p,newvar ())) spl in
+      let ty = newty (Ttuple(List.map snd spl_ann)) in
+      unify_pat_types loc !env ty expected_ty;
+      let pl = List.map (fun (p,t) -> type_pat p t) spl_ann in
       rp {
         pat_desc = Tpat_tuple pl;
         pat_loc = loc;
-        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_construct(lid, sarg, explicit_arity) ->
-      let constr = Typetexp.find_constructor env loc lid in
+      let constr =
+        match lid, constrs with
+          Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
+            Hashtbl.find constrs s
+        | _ ->  Typetexp.find_constructor !env loc lid
+      in
+      Env.mark_constructor `Pattern !env (Longident.last lid) constr;
+      if no_existentials && constr.cstr_existentials <> [] then
+        raise (Error (loc, Unexpected_existential));
+      (* if constructor is gadt, we must verify that the expected type has the
+         correct head *)
+      if constr.cstr_generalized then
+        unify_head_only loc !env expected_ty constr;
       let sargs =
         match sarg with
           None -> []
@@ -467,16 +687,21 @@ let rec type_pat env sp =
       if List.length sargs <> constr.cstr_arity then
         raise(Error(loc, Constructor_arity_mismatch(lid,
                                      constr.cstr_arity, List.length sargs)));
-      let args = List.map (type_pat env) sargs in
-      let (ty_args, ty_res) = instance_constructor constr in
-      List.iter2 (unify_pat env) args ty_args;
+      let (ty_args, ty_res) =
+        instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
+      in
+      if constr.cstr_generalized && mode = Normal then
+        unify_pat_types_gadt loc env ty_res expected_ty
+      else
+        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, args);
         pat_loc = loc;
-        pat_type = ty_res;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_variant(l, sarg) ->
-      let arg = may_map (type_pat env) sarg in
+      let arg = may_map (fun p -> type_pat p (newvar())) sarg in
       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
       let row = { row_fields =
                     [l, Reither(arg = None, arg_type, true, ref None)];
@@ -485,112 +710,182 @@ let rec type_pat env sp =
                   row_more = newvar ();
                   row_fixed = false;
                   row_name = None } in
+      unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
       rp {
         pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
         pat_loc = loc;
-        pat_type = newty (Tvariant row);
-        pat_env = env }
+        pat_type =  expected_ty;
+        pat_env = !env }
   | Ppat_record(lid_sp_list, closed) ->
-      let ty = newvar() in
-      let type_label_pat (lid, sarg) =
-        let label = Typetexp.find_label env loc lid in
+      let type_label_pat (label, sarg) =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
         if vars = [] then end_def ();
         begin try
-          unify env ty_res ty
+          unify_pat_types loc !env ty_res expected_ty
         with Unify trace ->
-          raise(Error(loc, Label_mismatch(lid, trace)))
+          raise(Error(loc, Label_mismatch(lid_of_label label, trace)))
         end;
-        let arg = type_pat env sarg in
-        unify_pat env arg ty_arg;
+        let arg = type_pat sarg ty_arg in
         if vars <> [] then begin
           end_def ();
           generalize ty_arg;
           List.iter generalize vars;
           let instantiated tv =
-            let tv = expand_head env tv in
-            tv.desc <> Tvar || tv.level <> generic_level in
+            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))
+            raise (Error(loc, Polymorphic_label (lid_of_label label)))
         end;
         (label, arg)
       in
-      let lbl_pat_list = type_label_a_list type_label_pat lid_sp_list in
+      let lbl_pat_list =
+        type_label_a_list ?labels !env loc type_label_pat lid_sp_list in
       check_recordpat_labels loc lbl_pat_list closed;
       rp {
         pat_desc = Tpat_record lbl_pat_list;
         pat_loc = loc;
-        pat_type = ty;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_array spl ->
-      let pl = List.map (type_pat env) spl in
       let ty_elt = newvar() in
-      List.iter (fun p -> unify_pat env p ty_elt) pl;
+      unify_pat_types
+        loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
+      let spl_ann = List.map (fun p -> (p,newvar())) spl in
+      let pl = List.map (fun (p,t) -> type_pat p ty_elt) spl_ann in
       rp {
         pat_desc = Tpat_array pl;
         pat_loc = loc;
-        pat_type = instance (Predef.type_array ty_elt);
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_or(sp1, sp2) ->
       let initial_pattern_variables = !pattern_variables in
-      let p1 = type_pat env sp1 in
+      let p1 = type_pat ~mode:Inside_or sp1 expected_ty in
       let p1_variables = !pattern_variables in
-      pattern_variables := initial_pattern_variables ;
-      let p2 = type_pat env sp2 in
+      pattern_variables := initial_pattern_variables;
+      let p2 = type_pat ~mode:Inside_or sp2 expected_ty in
       let p2_variables = !pattern_variables in
-      unify_pat env p2 p1.pat_type;
       let alpha_env =
-        enter_orpat_variables loc env p1_variables p2_variables in
-      pattern_variables := p1_variables ;
+        enter_orpat_variables loc !env p1_variables p2_variables in
+      pattern_variables := p1_variables;
       rp {
         pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
         pat_loc = loc;
-        pat_type = p1.pat_type;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_lazy sp1 ->
-      let p1 = type_pat env sp1 in
+      let nv = newvar () in
+      unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) expected_ty;
+      let p1 = type_pat sp1 nv in
       rp {
         pat_desc = Tpat_lazy p1;
         pat_loc = loc;
-        pat_type = instance (Predef.type_lazy_t p1.pat_type);
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_constraint(sp, sty) ->
-      let p = type_pat env sp in
-      let ty, force = Typetexp.transl_simple_type_delayed env sty in
-      unify_pat env p ty;
+      (* Separate when not already separated by !principal *)
+      let separate = true in
+      if separate then begin_def();
+      let ty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let ty, expected_ty' =
+        if separate then begin
+          end_def();
+          generalize_structure ty;
+          instance !env ty, instance !env ty
+        end else ty, ty
+      in
+      unify_pat_types loc !env ty expected_ty;
+      let p = type_pat sp expected_ty' in
+      (*Format.printf "%a@.%a@."
+        Printtyp.raw_type_expr ty
+        Printtyp.raw_type_expr p.pat_type;*)
       pattern_force := force :: !pattern_force;
-      p
+      if separate then
+        match p.pat_desc with
+          Tpat_var id ->
+            {p with pat_type = ty;
+             pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id)}
+        | _ -> {p with pat_type = ty}
+      else p
   | Ppat_type lid ->
-      build_or_pat env loc lid
+      let (r,ty) = build_or_pat !env loc lid in
+      unify_pat_types loc !env ty expected_ty;
+      r
 
-let get_ref r =
-  let v = !r in r := []; v
+let type_pat ?(allow_existentials=false) ?constrs ?labels
+    ?(lev=get_current_level()) env sp expected_ty =
+  newtype_level := Some lev;
+  try
+    let r =
+      type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
+        ~mode:Normal ~env sp expected_ty in
+    iter_pattern (fun p -> p.pat_env <- !env) r;
+    newtype_level := None;
+    r
+  with e ->
+    newtype_level := None;
+    raise e
+
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev env expected_ty constrs labels p =
+  let snap = snapshot () in
+  try
+    reset_pattern None true;
+    let typed_p =
+      type_pat ~allow_existentials:true ~lev
+        ~constrs ~labels (ref env) p expected_ty
+    in
+    backtrack snap;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with _ ->
+    backtrack snap;
+    None
+
+let rec iter3 f lst1 lst2 lst3 =
+  match lst1,lst2,lst3 with
+  | x1::xs1,x2::xs2,x3::xs3 ->
+      f x1 x2 x3;
+      iter3 f xs1 xs2 xs3
+  | [],[],[] ->
+      ()
+  | _ ->
+      assert false
 
-let add_pattern_variables env =
+let add_pattern_variables ?check ?check_as env =
   let pv = get_ref pattern_variables in
-  List.fold_right
-    (fun (id, ty, loc) env ->
-       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
-       Env.add_annot id (Annot.Iref_internal loc) e1;
-    )
-    pv env
-
-let type_pattern env spat scope =
-  reset_pattern scope;
-  let pat = type_pat env spat in
-  let new_env = add_pattern_variables env in
-  (pat, new_env, get_ref pattern_force)
-
-let type_pattern_list env spatl scope =
-  reset_pattern scope;
-  let patl = List.map (type_pat env) spatl in
-  let new_env = add_pattern_variables env in
-  (patl, new_env, get_ref pattern_force)
+  (List.fold_right
+    (fun (id, ty, 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; val_loc = loc} env in
+       Env.add_annot id (Annot.Iref_internal loc) e1)
+    pv env,
+   get_ref module_variables)
+
+let type_pattern ~lev env spat scope expected_ty =
+  reset_pattern scope true;
+  let new_env = ref env in
+  let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
+  let new_env, unpacks =
+    add_pattern_variables !new_env
+      ~check:(fun s -> Warnings.Unused_var_strict s)
+      ~check_as:(fun s -> Warnings.Unused_var s) in
+  (pat, new_env, get_ref pattern_force, unpacks)
+
+let type_pattern_list env spatl scope expected_tys allow =
+  reset_pattern scope allow;
+  let new_env = ref env in
+  let patl = List.map2 (type_pat new_env) spatl expected_tys in
+  let new_env, unpacks = add_pattern_variables !new_env in
+  (patl, new_env, get_ref pattern_force, unpacks)
 
 let type_class_arg_pattern cl_num val_env met_env l spat =
-  reset_pattern None;
-  let pat = type_pat val_env spat in
+  reset_pattern None false;
+  let nv = newvar () in
+  let pat = type_pat (ref val_env) spat nv in
   if has_variants pat then begin
     Parmatch.pressure_variants val_env [pat];
     iter_pattern finalize_variant pat
@@ -599,15 +894,20 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   if is_optional l then unify_pat val_env pat (type_option (newvar ()));
   let (pv, met_env) =
     List.fold_right
-      (fun (id, ty, _loc) (pv, env) ->
+      (fun (id, ty, loc, as_var) (pv, env) ->
+         let check s =
+           if as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
          let id' = Ident.create (Ident.name id) in
          ((id', id, ty)::pv,
           Env.add_value id' {val_type = ty;
-                             val_kind = Val_ivar (Immutable, cl_num)}
+                             val_kind = Val_ivar (Immutable, cl_num);
+                             val_loc = loc;
+                            } ~check
             env))
       !pattern_variables ([], met_env)
   in
-  let val_env = add_pattern_variables val_env in
+  let val_env, _ = add_pattern_variables val_env in
   (pat, pv, val_env, met_env)
 
 let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
@@ -617,8 +917,9 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                        "selfpat-" ^ cl_num))
   in
-  reset_pattern None;
-  let pat = type_pat val_env spat in
+  reset_pattern None false;
+  let nv = newvar() in
+  let pat = type_pat (ref val_env) spat nv in
   List.iter (fun f -> f()) (get_ref pattern_force);
   let meths = ref Meths.empty in
   let vars = ref Vars.empty in
@@ -626,12 +927,21 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty, _loc) (val_env, met_env, par_env) ->
-         (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
+      (fun (id, ty, loc, as_var) (val_env, met_env, par_env) ->
+         (Env.add_value id {val_type = ty;
+                            val_kind = Val_unbound;
+                            val_loc = loc;
+                           } val_env,
           Env.add_value id {val_type = ty;
-                            val_kind = Val_self (meths, vars, cl_num, privty)}
+                            val_kind = Val_self (meths, vars, cl_num, privty);
+                            val_loc = loc;
+                           }
+            ~check:(fun s -> if as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
             met_env,
-          Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
+          Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                            val_loc = loc;
+                           } par_env))
       pv (val_env, met_env, par_env)
   in
   (pat, meths, vars, val_env, met_env, par_env)
@@ -685,7 +995,7 @@ let rec is_nonexpansive exp =
             Cf_meth _ -> true
           | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
           | Cf_init e -> is_nonexpansive e
-          | Cf_inher _ | Cf_let _ -> false)
+          | Cf_inher _ -> false)
         fields &&
       Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
         vars true &&
@@ -720,7 +1030,11 @@ and is_nonexpansive_opt = function
     None -> true
   | Some e -> is_nonexpansive e
 
-(* Typing of printf formats.
+(* Typing format strings for printing or reading.
+
+   These format strings are used by functions in modules Printf, Format, and
+   Scanf.
+
    (Handling of * modifiers contributed by Thorsten Ohl.) *)
 
 external string_to_format :
@@ -730,32 +1044,13 @@ external format_to_string :
 
 let type_format loc fmt =
 
-  let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
+  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
   let incomplete_format fmt =
     raise (Error (loc, Incomplete_format fmt)) in
 
-  let range_closing_index fmt i =
-
-    let len = String.length fmt in
-    let find_closing j =
-      if j >= len then incomplete_format fmt else
-      try String.index_from fmt j ']' with
-      | Not_found -> incomplete_format fmt in
-    let skip_pos j =
-      if j >= len then incomplete_format fmt else
-      match fmt.[j] with
-      | ']' -> find_closing (j + 1)
-      | c -> find_closing j in
-    let rec skip_neg j =
-      if j >= len then incomplete_format fmt else
-      match fmt.[j] with
-      | '^' -> skip_pos (j + 1)
-      | c -> skip_pos j in
-    find_closing (skip_neg (i + 1)) in
-
   let rec type_in_format fmt =
 
     let len = String.length fmt in
@@ -805,6 +1100,48 @@ let type_format loc fmt =
         match fmt.[j] with
         | '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
         | _ -> scan_conversion i j
+      and scan_indication j =
+        if j >= len then j - 1 else
+        match fmt.[j] with
+        | '@' ->
+          let k = j + 1 in
+          if k >= len then j - 1 else
+          begin match fmt.[k] with
+          | '%' ->
+            let k = k + 1 in
+            if k >= len then j - 1 else
+            begin match fmt.[k] with
+            | '%' | '@' -> k
+            | _c -> j - 1
+            end
+          | _c -> k
+          end
+        | _c -> j - 1
+      and scan_range j =
+        let rec scan_closing j =
+          if j >= len then incomplete_format fmt else
+          match fmt.[j] with
+          | ']' -> j
+          | '%' ->
+            let j = j + 1 in
+            if j >= len then incomplete_format fmt else
+            begin match fmt.[j] with
+            | '%' | '@' -> scan_closing (j + 1)
+            | c -> bad_conversion fmt j c
+            end
+          | c -> scan_closing (j + 1) in
+        let scan_first_pos j =
+          if j >= len then incomplete_format fmt else
+          match fmt.[j] with
+          | ']' -> scan_closing (j + 1)
+          | c -> scan_closing j in
+        let rec scan_first_neg j =
+          if j >= len then incomplete_format fmt else
+          match fmt.[j] with
+          | '^' -> scan_first_pos (j + 1)
+          | c -> scan_first_pos j in
+
+        scan_first_neg j
 
       and conversion j ty_arg =
         let ty_uresult, ty_result = scan_format (j + 1) in
@@ -824,13 +1161,16 @@ let type_format loc fmt =
       and scan_conversion i j =
         if j >= len then incomplete_format fmt else
         match fmt.[j] with
-        | '%' | '!' | ',' -> scan_format (j + 1)
-        | 's' | 'S' -> conversion j Predef.type_string
+        | '%' | '@' | '!' | ',' -> scan_format (j + 1)
+        | 's' | 'S' ->
+          let j = scan_indication (j + 1) in
+          conversion j Predef.type_string
         | '[' ->
-          let j = range_closing_index fmt j in
+          let j = scan_range (j + 1) in
+          let j = scan_indication (j + 1) in
           conversion j Predef.type_string
         | 'c' | 'C' -> conversion j Predef.type_char
-        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
+        | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' ->
           conversion j Predef.type_int
         | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
         | 'B' | 'b' -> conversion j Predef.type_bool
@@ -859,7 +1199,7 @@ let type_format loc fmt =
           let j = j + 1 in
           if j >= len then conversion (j - 1) Predef.type_int else begin
             match fmt.[j] with
-            | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+            | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
               let ty_arg =
                 match c with
                 | 'l' -> Predef.type_int32
@@ -888,9 +1228,10 @@ let type_format loc fmt =
     let ty_ureader, ty_args = scan_format 0 in
     newty
       (Tconstr
-         (Predef.path_format6,
-          [ty_args; ty_input; ty_aresult; ty_ureader; ty_uresult; ty_result],
-          ref Mnil)) in
+        (Predef.path_format6,
+         [ ty_args; ty_input; ty_aresult;
+           ty_ureader; ty_uresult; ty_result; ],
+         ref Mnil)) in
 
   type_in_format fmt
 
@@ -950,7 +1291,7 @@ let rec list_labels_aux env visited ls ty_fun =
     Tarrow (l, _, ty_res, _) ->
       list_labels_aux env (ty::visited) (l::ls) ty_res
   | _ ->
-      List.rev ls, ty.desc = Tvar
+      List.rev ls, is_Tvar ty
 
 let list_labels env ty = list_labels_aux env [] [] ty
 
@@ -966,9 +1307,10 @@ let check_univars env expans kind exp ty_expected vars =
       (fun t ->
         let t = repr t in
         generalize t;
-        if t.desc = Tvar && t.level = generic_level then
-          (log_type t; t.desc <- Tunivar; true)
-        else false)
+        match t.desc with
+          Tvar name when t.level = generic_level ->
+            log_type t; t.desc <- Tunivar name; true
+        | _ -> false)
       vars in
   if List.length vars = List.length vars' then () else
   let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
@@ -982,7 +1324,7 @@ let check_application_result env statement exp =
   match (expand_head env exp.exp_type).desc with
   | Tarrow _ ->
       Location.prerr_warning exp.exp_loc Warnings.Partial_application
-  | Tvar -> ()
+  | Tvar _ -> ()
   | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
   | _ ->
       if statement then
@@ -1007,42 +1349,111 @@ let create_package_type loc env (p, l) =
   let s = !Typetexp.transl_modtype_longident loc env p in
   newty (Tpackage (s,
                    List.map fst l,
-                   List.map (Typetexp.transl_simple_type env false) (List.map snd l)))
+                   List.map (Typetexp.transl_simple_type env false)
+                     (List.map snd l)))
+
+let wrap_unpacks sexp unpacks =
+  List.fold_left
+    (fun sexp (name, loc) ->
+      {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule (
+       name,
+       {pmod_loc = loc; pmod_desc = Pmod_unpack
+          {pexp_desc=Pexp_ident(Longident.Lident name); pexp_loc=loc}},
+       sexp)})
+    sexp unpacks
+
+(* Helpers for type_cases *)
+let iter_ppat f p = 
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ 
+  | Ppat_type _ | Ppat_unpack _ -> ()    
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args
+
+let contains_polymorphic_variant p =
+  let rec loop p =
+    match p.ppat_desc with
+      Ppat_variant _ | Ppat_type _ -> raise Exit
+    | _ -> iter_ppat loop p
+  in
+  try loop p; false with Exit -> true
+
+let contains_gadt env p =
+  let rec loop p =
+    match p.ppat_desc with
+      Ppat_construct (lid, _, _) ->
+        begin try
+          if (Env.lookup_constructor lid env).cstr_generalized then raise Exit
+        with Not_found -> ()
+        end; iter_ppat loop p
+    | _ -> iter_ppat loop p
+  in
+  try loop p; false with Exit -> true
+
+let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
+
+(* Duplicate types of values in the environment *)
+(* XXX Should we do something about global type variables too? *)
+
+let duplicate_ident_types loc caselist env =
+  let caselist =
+    List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
+  let idents = all_idents (List.map snd caselist) in
+  List.fold_left
+    (fun env s ->
+      try
+        (* XXX This will mark the value as being used;
+           I don't think this is what we want *)
+        let (path, desc) = Env.lookup_value (Longident.Lident s) env in
+        match path with
+          Path.Pident id ->
+            let desc = {desc with val_type = correct_levels desc.val_type} in
+            Env.add_value id desc env
+        | _ -> env
+      with Not_found -> env)
+    env idents
 
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
   (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
     Printtyp.raw_type_expr expected_ty; *)
-  try
-    unify env exp.exp_type expected_ty
-  with
-    Unify trace ->
-      raise(Error(exp.exp_loc, Expr_type_clash(trace)))
-  | Tags(l1,l2) ->
-      raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
+    unify_exp_types exp.exp_loc env exp.exp_type expected_ty
 
 let rec type_exp env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect env sexp (newvar ())
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+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 =
+    Stypes.record (Stypes.Ti_expr exp);
+    unify_exp env exp (instance env ty_expected);
+    exp
+  in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
       begin
         if !Clflags.annotations then begin
           try let (path, annot) = Env.lookup_annot lid env in
-              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 ^ ")" in
               Stypes.record
-                (Stypes.An_ident (loc, name_of_path path, annot))
+                (Stypes.An_ident (
+                 loc, Path.name ~paren:Oprint.parenthesized_ident path, annot))
           with _ -> ()
         end;
         let (path, desc) = Typetexp.find_value env loc lid in
-        re {
+        rue {
           exp_desc =
             begin match desc.val_kind with
               Val_ivar (_, cl_num) ->
@@ -1061,15 +1472,31 @@ let rec type_exp env sexp =
                 Texp_ident(path, desc)
             end;
           exp_loc = loc;
-          exp_type = instance desc.val_type;
+          exp_type = instance env desc.val_type;
           exp_env = env }
       end
+  | Pexp_constant(Const_string s as cst) ->
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc;
+        exp_type =
+        (* Terrible hack for format strings *)
+           begin match (repr (expand_head env ty_expected)).desc with
+             Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
+               type_format loc s
+           | _ -> instance_def Predef.type_string
+           end;
+        exp_env = env }
   | Pexp_constant cst ->
-      re {
+      rue {
         exp_desc = Texp_constant cst;
         exp_loc = loc;
         exp_type = type_constant cst;
         exp_env = env }
+  | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
+      type_expect ?in_function env
+        {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
+        ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let scp =
         match rec_flag with
@@ -1077,15 +1504,102 @@ let rec type_exp env sexp =
         | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
         | Default -> None
       in
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
-      let body = type_exp new_env sbody in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let env rec_flag spat_sexp_list scp true in
+      let body =
+        type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = loc;
         exp_type = body.exp_type;
         exp_env = env }
-  | Pexp_function _ ->     (* defined in type_expect *)
-      type_expect env sexp (newvar())
+  | Pexp_function (l, Some default, [spat, sbody]) ->
+      let default_loc = default.pexp_loc in
+      let scases = [
+         {ppat_loc = default_loc;
+          ppat_desc =
+            Ppat_construct
+              (Longident.(Ldot (Lident "*predef*", "Some")),
+               Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"},
+               false)},
+         {pexp_loc = default_loc;
+          pexp_desc = Pexp_ident(Longident.Lident "*sth*")};
+         {ppat_loc = default_loc;
+          ppat_desc = Ppat_construct
+            (Longident.(Ldot (Lident "*predef*", "None")), None, false)},
+         default;
+      ] in
+      let smatch = {
+        pexp_loc = loc;
+        pexp_desc =
+          Pexp_match ({
+            pexp_loc = loc;
+            pexp_desc = Pexp_ident(Longident.Lident "*opt*")
+            },
+            scases
+          )
+      } in
+      let sfun = {
+        pexp_loc = loc;
+        pexp_desc =
+         Pexp_function (
+           l, None,
+           [ {ppat_loc = loc;
+              ppat_desc = Ppat_var "*opt*"},
+             {pexp_loc = loc;
+              pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
+             }
+           ]
+         )
+      } in
+      type_expect ?in_function env sfun ty_expected
+  | Pexp_function (l, _, caselist) ->
+      let (loc_fun, ty_fun) =
+        match in_function with Some p -> p
+        | None -> (loc, instance env ty_expected)
+      in
+      let separate = !Clflags.principal || Env.has_local_constraints env in
+      if separate then begin_def ();
+      let (ty_arg, ty_res) =
+        try filter_arrow env (instance env ty_expected) l
+        with Unify _ ->
+          match expand_head env ty_expected with
+            {desc = Tarrow _} as ty ->
+              raise(Error(loc, Abstract_wrong_label(l, ty)))
+          | _ ->
+              raise(Error(loc_fun,
+                          Too_many_arguments (in_function <> None, ty_fun)))
+      in
+      let ty_arg =
+        if is_optional l then
+          let tv = newvar() in
+          begin
+            try unify env ty_arg (type_option tv)
+            with Unify _ -> assert false
+          end;
+          type_option tv
+        else ty_arg
+      in
+      if separate then begin
+        end_def ();
+        generalize_structure ty_arg;
+        generalize_structure ty_res
+      end;
+      let cases, partial =
+        type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
+          true loc caselist in
+      let not_function ty =
+        let ls, tvar = list_labels env ty in
+        ls = [] && not tvar
+      in
+      if is_optional l && not_function ty_res then
+        Location.prerr_warning (fst (List.hd cases)).pat_loc
+          Warnings.Unerasable_optional_argument;
+      re {
+        exp_desc = Texp_function(cases, partial);
+        exp_loc = loc;
+        exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+        exp_env = env }
   | Pexp_apply(sfunct, sargs) ->
       begin_def (); (* one more level for non-returning functions *)
       if !Clflags.principal then begin_def ();
@@ -1099,69 +1613,96 @@ let rec type_exp env sexp =
         if List.memq ty seen then () else
         match ty.desc with
           Tarrow (l, ty_arg, ty_fun, com) ->
-            unify_var env (newvar()) ty_arg;
+            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
             lower_args (ty::seen) ty_fun
         | _ -> ()
       in
-      let ty = instance funct.exp_type in
+      let ty = instance env funct.exp_type in
       end_def ();
       lower_args [] ty;
       begin_def ();
       let (args, ty_res) = type_application env funct sargs in
       end_def ();
       unify_var env (newvar()) funct.exp_type;
-      re {
+      rue {
         exp_desc = Texp_apply(funct, args);
         exp_loc = loc;
         exp_type = ty_res;
         exp_env = env }
   | Pexp_match(sarg, caselist) ->
+      begin_def ();
       let arg = type_exp env sarg in
-      let ty_res = newvar() in
+      end_def ();
+      if is_nonexpansive arg then generalize arg.exp_type
+      else generalize_expansive env arg.exp_type;
       let cases, partial =
-        type_cases env arg.exp_type ty_res (Some loc) caselist
+        type_cases env arg.exp_type ty_expected true loc caselist
       in
       re {
         exp_desc = Texp_match(arg, cases, partial);
         exp_loc = loc;
-        exp_type = ty_res;
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_try(sbody, caselist) ->
-      let body = type_exp env sbody in
+      let body = type_expect env sbody ty_expected in
       let cases, _ =
-        type_cases
-          env (instance Predef.type_exn) body.exp_type None caselist in
+        type_cases env Predef.type_exn ty_expected false loc caselist in
       re {
         exp_desc = Texp_try(body, cases);
         exp_loc = loc;
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_tuple sexpl ->
-      let expl = List.map (type_exp env) sexpl in
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      unify_exp_types loc env to_unify ty_expected;
+      let expl =
+        List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
+      in
       re {
         exp_desc = Texp_tuple expl;
         exp_loc = loc;
-        exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
         exp_env = env }
   | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct env loc lid sarg explicit_arity (newvar ())
+      type_construct env loc lid sarg explicit_arity ty_expected
   | Pexp_variant(l, sarg) ->
-      let arg = may_map (type_exp env) sarg in
-      let arg_type = may_map (fun arg -> arg.exp_type) arg in
-      re {
-        exp_desc = Texp_variant(l, arg);
-        exp_loc = loc;
-        exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
-                                  row_more = newvar ();
-                                  row_bound = ();
-                                  row_closed = false;
-                                  row_fixed = false;
-                                  row_name = None});
-        exp_env = env }
+      (* Keep sharing *)
+      let ty_expected0 = instance env ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc;
+                   exp_type = ty_expected0;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = may_map (type_exp env) sarg in
+        let arg_type = may_map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc;
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = false;
+                                    row_name = None});
+          exp_env = env }
+      end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
-      let ty = newvar () in
       let lbl_exp_list =
-        type_label_a_list (type_label_exp true env loc ty) lid_sexp_list in
+        type_label_a_list env loc (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) ->
@@ -1174,6 +1715,7 @@ let rec type_exp env sexp =
         match opt_sexp, lbl_exp_list with
           None, _ -> None
         | Some sexp, (lbl, _) :: _ ->
+            if !Clflags.principal then begin_def ();
             let ty_exp = newvar () in
             let unify_kept lbl =
               if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
@@ -1182,10 +1724,14 @@ let rec type_exp env sexp =
                 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 ty_res2;
+                unify env (instance env ty_expected) ty_res2;
                 unify env ty_arg1 ty_arg2
               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)
         | _ -> assert false
       in
@@ -1195,7 +1741,7 @@ let rec type_exp env sexp =
       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
-        let label_names = extract_label_names sexp env ty in
+        let label_names = extract_label_names sexp env ty_expected in
         let rec missing_labels n = function
             [] -> []
           | lbl :: rem ->
@@ -1210,50 +1756,55 @@ let rec type_exp env sexp =
       re {
         exp_desc = Texp_record(lbl_exp_list, opt_exp);
         exp_loc = loc;
-        exp_type = ty;
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_field(sarg, lid) ->
       let arg = type_exp env sarg in
       let label = Typetexp.find_label env loc lid in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env arg ty_res;
-      re {
+      rue {
         exp_desc = Texp_field(arg, label);
         exp_loc = loc;
         exp_type = ty_arg;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
       let record = type_exp env srecord in
+      let label = Typetexp.find_label env loc lid in
       let (label, newval) =
-        type_label_exp false env loc record.exp_type (lid, snewval) in
+        type_label_exp false env loc record.exp_type (label, snewval) in
       if label.lbl_mut = Immutable then
         raise(Error(loc, Label_not_mutable lid));
-      re {
+      rue {
         exp_desc = Texp_setfield(record, label, newval);
         exp_loc = loc;
-        exp_type = instance Predef.type_unit;
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_array(sargl) ->
-      let ty = newvar() in
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      unify_exp_types loc env to_unify ty_expected;
       let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
       re {
         exp_desc = Texp_array argl;
         exp_loc = loc;
-        exp_type = instance (Predef.type_array ty);
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_ifthenelse(scond, sifso, sifnot) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
+      let cond = type_expect env scond Predef.type_bool in
       begin match sifnot with
         None ->
-          let ifso = type_expect env sifso (instance Predef.type_unit) in
-          re {
+          let ifso = type_expect env sifso Predef.type_unit in
+          rue {
             exp_desc = Texp_ifthenelse(cond, ifso, None);
             exp_loc = loc;
-            exp_type = instance Predef.type_unit;
+            exp_type = ifso.exp_type;
             exp_env = env }
       | Some sifnot ->
-          let ifso = type_exp env sifso in
-          let ifnot = type_expect env sifnot ifso.exp_type in
+          let ifso = type_expect env sifso ty_expected in
+          let ifnot = type_expect env sifnot ty_expected in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
           re {
             exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
             exp_loc = loc;
@@ -1262,56 +1813,61 @@ let rec type_exp env sexp =
       end
   | Pexp_sequence(sexp1, sexp2) ->
       let exp1 = type_statement env sexp1 in
-      let exp2 = type_exp env sexp2 in
+      let exp2 = type_expect env sexp2 ty_expected in
       re {
         exp_desc = Texp_sequence(exp1, exp2);
         exp_loc = loc;
         exp_type = exp2.exp_type;
         exp_env = env }
   | Pexp_while(scond, sbody) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
+      let cond = type_expect env scond Predef.type_bool in
       let body = type_statement env sbody in
-      re {
+      rue {
         exp_desc = Texp_while(cond, body);
         exp_loc = loc;
-        exp_type = instance Predef.type_unit;
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_for(param, slow, shigh, dir, sbody) ->
-      let low = type_expect env slow (instance Predef.type_int) in
-      let high = type_expect env shigh (instance Predef.type_int) in
+      let low = type_expect env slow Predef.type_int in
+      let high = type_expect env shigh Predef.type_int in
       let (id, new_env) =
-        Env.enter_value param {val_type = instance Predef.type_int;
-                                val_kind = Val_reg} env in
+        Env.enter_value param {val_type = instance_def Predef.type_int;
+                               val_kind = Val_reg;
+                               val_loc = loc;
+                              } env
+          ~check:(fun s -> Warnings.Unused_for_index s)
+      in
       let body = type_statement new_env sbody in
-      re {
+      rue {
         exp_desc = Texp_for(id, low, high, dir, body);
         exp_loc = loc;
-        exp_type = instance Predef.type_unit;
+        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') =
         match (sty, sty') with
           (None, None) ->               (* Case actually unused *)
             let arg = type_exp env sarg in
             (arg, arg.exp_type)
         | (Some sty, None) ->
-            if !Clflags.principal then begin_def ();
+            if separate then begin_def ();
             let ty = Typetexp.transl_simple_type env false sty in
-            if !Clflags.principal then begin
+            if separate then begin
               end_def ();
               generalize_structure ty;
-              let ty1 = instance ty and ty2 = instance ty in
-              (type_expect env sarg ty1, ty2)
+              (type_argument env sarg ty (instance env ty), instance env ty)
             end else
-              (type_expect env sarg ty, ty)
+              (type_argument env sarg ty ty, ty)
         | (None, Some sty') ->
             let (ty', force) =
               Typetexp.transl_simple_type_delayed env sty'
             in
-            if !Clflags.principal then begin_def ();
+            if separate then begin_def ();
             let arg = type_exp env sarg in
             let gen =
-              if !Clflags.principal then begin
+              if separate then begin
                 end_def ();
                 let tv = newvar () in
                 let gen = generalizable tv.level arg.exp_type in
@@ -1355,6 +1911,7 @@ let rec type_exp env sexp =
             end;
             (arg, ty')
         | (Some sty, Some sty') ->
+            if separate then begin_def ();
             let (ty, force) =
               Typetexp.transl_simple_type_delayed env sty
             and (ty', force') =
@@ -1366,16 +1923,22 @@ let rec type_exp env sexp =
             with Subtype (tr1, tr2) ->
               raise(Error(loc, Not_subtype(tr1, tr2)))
             end;
-            (type_expect env sarg ty, ty')
+            if separate then begin
+              end_def ();
+              generalize_structure ty;
+              generalize_structure ty';
+              (type_argument env sarg ty (instance env ty), instance env ty')
+            end else
+              (type_argument env sarg ty ty, ty')
       in
-      re {
+      rue {
         exp_desc = arg.exp_desc;
         exp_loc = arg.exp_loc;
         exp_type = ty';
         exp_env = env }
   | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
-      let body = type_exp env sbody in
+      let cond = type_expect env scond Predef.type_bool in
+      let body = type_expect env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
         exp_loc = loc;
@@ -1391,7 +1954,7 @@ let rec type_exp env sexp =
               let (id, typ) =
                 filter_self_method env met Private meths privty
               in
-              if (repr typ).desc = Tvar then
+              if is_Tvar (repr typ) then
                 Location.prerr_warning loc
                   (Warnings.Undeclared_virtual_method met);
               (Texp_send(obj, Tmeth_val id), typ)
@@ -1413,10 +1976,12 @@ let rec type_exp env sexp =
                   let method_type = newvar () in
                   let (obj_ty, res_ty) = filter_arrow env method_type "" in
                   unify env obj_ty desc.val_type;
-                  unify env res_ty (instance typ);
+                  unify env res_ty (instance env typ);
                   (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
                                                      {val_type = method_type;
-                                                       val_kind = Val_reg});
+                                                      val_kind = Val_reg;
+                                                      val_loc = Location.none;
+                                                     });
                                 exp_loc = loc;
                                 exp_type = method_type;
                                 exp_env = env },
@@ -1440,26 +2005,26 @@ let rec type_exp env sexp =
         let typ =
           match repr typ with
             {desc = Tpoly (ty, [])} ->
-              instance ty
+              instance env ty
           | {desc = Tpoly (ty, tl); level = l} ->
               if !Clflags.principal && l <> generic_level then
                 Location.prerr_warning loc
                   (Warnings.Not_principal "this use of a polymorphic method");
               snd (instance_poly false tl ty)
-          | {desc = Tvar} as ty ->
+          | {desc = Tvar _} as ty ->
               let ty' = newvar () in
-              unify env (instance ty) (newty(Tpoly(ty',[])));
+              unify env (instance_def ty) (newty(Tpoly(ty',[])));
               (* if not !Clflags.nolabels then
                  Location.prerr_warning loc (Warnings.Unknown_method met); *)
               ty'
           | _ ->
               assert false
         in
-          re {
-            exp_desc = exp;
-            exp_loc = loc;
-            exp_type = typ;
-            exp_env = env }
+        rue {
+          exp_desc = exp;
+          exp_loc = loc;
+          exp_type = typ;
+          exp_env = env }
       with Unify _ ->
         raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
       end
@@ -1469,10 +2034,10 @@ let rec type_exp env sexp =
           None ->
             raise(Error(loc, Virtual_class cl))
         | Some ty ->
-            re {
+            rue {
               exp_desc = Texp_new (cl_path, cl_decl);
               exp_loc = loc;
-              exp_type = instance ty;
+              exp_type = instance_def ty;
               exp_env = env }
         end
   | Pexp_setinstvar (lab, snewval) ->
@@ -1480,14 +2045,14 @@ let rec type_exp env sexp =
         let (path, desc) = Env.lookup_value (Longident.Lident lab) env in
         match desc.val_kind with
           Val_ivar (Mutable, cl_num) ->
-            let newval = type_expect env snewval (instance desc.val_type) in
+            let newval = type_expect env snewval (instance env desc.val_type) in
             let (path_self, _) =
               Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
             in
-            re {
+            rue {
               exp_desc = Texp_setinstvar(path_self, path, newval);
               exp_loc = loc;
-              exp_type = instance Predef.type_unit;
+              exp_type = instance_def Predef.type_unit;
               exp_env = env }
         | Val_ivar _ ->
             raise(Error(loc,Instance_variable_not_mutable(true,lab)))
@@ -1519,14 +2084,14 @@ let rec type_exp env sexp =
           let type_override (lab, snewval) =
             begin try
               let (id, _, _, ty) = Vars.find lab !vars in
-              (Path.Pident id, type_expect env snewval (instance ty))
+              (Path.Pident id, type_expect env snewval (instance env ty))
             with
               Not_found ->
                 raise(Error(loc, Unbound_instance_variable lab))
             end
           in
           let modifs = List.map type_override lst in
-          re {
+          rue {
             exp_desc = Texp_override(path_self, modifs);
             exp_loc = loc;
             exp_type = self_ty;
@@ -1536,20 +2101,24 @@ let rec type_exp env sexp =
       end
   | Pexp_letmodule(name, smodl, sbody) ->
       let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
       Ident.set_current_time ty.level;
       let context = Typetexp.narrow () in
       let modl = !type_module env smodl in
       let (id, new_env) = Env.enter_module name modl.mod_type env in
       Ctype.init_def(Ident.current_time());
       Typetexp.widen context;
-      let body = type_exp new_env sbody in
+      let body = type_expect new_env sbody ty_expected in
+      (* go back to original level *)
+      end_def ();
       (* Unification of body.exp_type with the fresh variable ty
          fails if and only if the prefix condition is violated,
          i.e. if generative types rooted at id show up in the
          type body.exp_type.  Thus, this unification enforces the
          scoping condition on "let module". *)
       begin try
-        Ctype.unify new_env body.exp_type ty
+        Ctype.unify_var new_env ty body.exp_type
       with Unify _ ->
         raise(Error(loc, Scoping_let_module(name, body.exp_type)))
       end;
@@ -1559,40 +2128,81 @@ let rec type_exp env sexp =
         exp_type = ty;
         exp_env = env }
   | Pexp_assert (e) ->
-       let cond = type_expect env e (instance Predef.type_bool) in
-       re {
-         exp_desc = Texp_assert (cond);
-         exp_loc = loc;
-         exp_type = instance Predef.type_unit;
-         exp_env = env;
-       }
+      let cond = type_expect env e Predef.type_bool in
+      rue {
+        exp_desc = Texp_assert (cond);
+        exp_loc = loc;
+        exp_type = instance_def Predef.type_unit;
+        exp_env = env;
+      }
   | Pexp_assertfalse ->
-       re {
-         exp_desc = Texp_assertfalse;
-         exp_loc = loc;
-         exp_type = newvar ();
-         exp_env = env;
-       }
+      re {
+        exp_desc = Texp_assertfalse;
+        exp_loc = loc;
+        exp_type = instance env ty_expected;
+        exp_env = env;
+      }
   | Pexp_lazy e ->
-       let arg = type_exp env e in
-       re {
-         exp_desc = Texp_lazy arg;
-         exp_loc = loc;
-         exp_type = instance (Predef.type_lazy_t arg.exp_type);
-         exp_env = env;
-       }
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      unify_exp_types loc env to_unify ty_expected;
+      let arg = type_expect env e ty in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc;
+        exp_type = instance env ty_expected;
+        exp_env = env;
+      }
   | Pexp_object s ->
       let desc, sign, meths = !type_object env loc s in
-      re {
+      rue {
         exp_desc = Texp_object (desc, sign, meths);
         exp_loc = loc;
         exp_type = sign.cty_self;
         exp_env = env;
       }
-  | Pexp_poly _ ->
-      assert false
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty =
+        match sty with None -> repr ty_expected
+        | Some sty ->
+            let ty = Typetexp.transl_simple_type env false sty in
+            repr ty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        unify_exp_types loc env (instance env ty) (instance env ty_expected);
+      begin
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody ty' in
+            re { exp with exp_type = instance env ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody ty'' in
+            end_def ();
+            check_univars env false "method" exp ty_expected vars;
+            re { exp with exp_type = instance env ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            re exp
+        | _ -> assert false
+      end
   | Pexp_newtype(name, sbody) ->
       (* Create a fake abstract type declaration for name. *)
+      let level = get_current_level () in
       let decl = {
         type_params = [];
         type_arity = 0;
@@ -1600,16 +2210,20 @@ let rec type_exp env sexp =
         type_private = Public;
         type_manifest = None;
         type_variance = [];
+        type_newtype_level = Some (level, level);
+        type_loc = loc;
       }
       in
-
       let ty = newvar () in
+      (* remember original level *)
+      begin_def ();
       Ident.set_current_time ty.level;
       let (id, new_env) = Env.enter_type name decl env in
       Ctype.init_def(Ident.current_time());
 
       let body = type_exp new_env sbody in
-      (* Replace every instance of this type constructor in the resulting type. *)
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
       let seen = Hashtbl.create 8 in
       let rec replace t =
         if Hashtbl.mem seen t.id then ()
@@ -1622,45 +2236,68 @@ let rec type_exp env sexp =
       in
       let ety = Subst.type_expr Subst.identity body.exp_type in
       replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
 
       (* non-expansive if the body is non-expansive, so we don't introduce
          any new extra node in the typed AST. *)
-      re { body with exp_loc = sexp.pexp_loc; exp_type = ety }
-  | Pexp_pack (m, (p, l)) ->
-      let loc = sexp.pexp_loc in
-      let l, mty = Typetexp.create_package_mty loc env (p, l) in
-      let m = {pmod_desc = Pmod_constraint (m, mty); pmod_loc = loc} in
-      let context = Typetexp.narrow () in
-      let modl = !type_module env m in
-      Typetexp.widen context;
-      re {
+      rue { body with exp_loc = sexp.pexp_loc; exp_type = ety }
+  | Pexp_pack m ->
+      let (p, nl, tl) =
+        match Ctype.expand_head env (instance env ty_expected) with
+          {desc = Tpackage (p, nl, tl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, nl, tl)
+        | {desc = Tvar _} ->
+            raise (Error (loc, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, Not_a_packed_module ty_expected))
+      in
+      let (modl, tl') = !type_package env m p nl tl in
+      rue {
         exp_desc = Texp_pack modl;
         exp_loc = loc;
-        exp_type = create_package_type loc env (p, l);
+        exp_type = newty (Tpackage (p, nl, tl'));
         exp_env = env }
   | Pexp_open (lid, e) ->
-      type_exp (!type_open env sexp.pexp_loc lid) e
+      type_expect (!type_open env sexp.pexp_loc lid) e ty_expected
 
-and type_label_exp create env loc ty (lid, sarg) =
-  let label = Typetexp.find_label env sarg.pexp_loc lid in
+and type_label_exp create env loc ty_expected (label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
   begin_def ();
-  if !Clflags.principal then begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
   let (vars, ty_arg, ty_res) = instance_label true label in
-  if !Clflags.principal then begin
+  if separate then begin
     end_def ();
+    (* Generalize label information *)
     generalize_structure ty_arg;
     generalize_structure ty_res
   end;
   begin try
-    unify env (instance ty_res) ty
+    unify env (instance_def ty_res) (instance env ty_expected)
   with Unify trace ->
-    raise(Error(loc , Label_mismatch(lid, trace)))
+    raise(Error(loc , Label_mismatch(lid_of_label label, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance_def ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
   end;
   if label.lbl_private = Private then
-    raise(Error(loc, if create then Private_type ty else Private_label (lid, ty)));
+    raise(Error(loc, if create then Private_type ty_expected
+                     else Private_label (lid_of_label label, ty_expected)));
   let arg =
     let snap = if vars = [] then None else Some (Btype.snapshot ()) in
-    let arg = type_argument env sarg ty_arg in
+    let arg = type_argument env sarg ty_arg (instance env ty_arg) in
     end_def ();
     try
       check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
@@ -1678,19 +2315,22 @@ and type_label_exp create env loc ty (lid, sarg) =
     with Error (_, Less_general _) as e -> raise e
     | _ -> raise exn    (* In case of failure return the first error *)
   in
-  (label, {arg with exp_type = instance arg.exp_type})
+  (label, {arg with exp_type = instance env arg.exp_type})
 
-and type_argument env sarg ty_expected' =
+and type_argument env sarg ty_expected' ty_expected =
   (* ty_expected' may be generic *)
   let no_labels ty =
     let ls, tvar = list_labels env ty in
     not tvar && List.for_all ((=) "") ls
   in
-  let ty_expected = instance ty_expected' in
-  match expand_head env ty_expected', sarg with
-  | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
-      type_expect env sarg ty_expected
-  | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
+  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
+    | _ -> false
+  in
+  match expand_head env ty_expected' with
+    {desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg ->
       (* apply optional arguments when expected type is "" *)
       (* we must be very careful about not breaking the semantics *)
       if !Clflags.principal then begin_def ();
@@ -1703,19 +2343,19 @@ and type_argument env sarg ty_expected' =
         match (expand_head env ty_fun).desc with
         | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
             make_args
-              ((Some(option_none (instance ty_arg) sarg.pexp_loc), Optional)
+              ((Some(option_none (instance env ty_arg) sarg.pexp_loc), Optional)
                :: args)
               ty_fun
         | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
             args, ty_fun, no_labels ty_res'
-        | Tvar ->  args, ty_fun, false
+        | Tvar _ ->  args, ty_fun, false
         |  _ -> [], texp.exp_type, false
       in
       let args, ty_fun', simple_res = make_args [] texp.exp_type in
       let warn = !Clflags.principal &&
         (lv <> generic_level || (repr ty_fun').level <> generic_level)
-      and texp = {texp with exp_type = instance texp.exp_type}
-      and ty_fun = instance ty_fun' in
+      and texp = {texp with exp_type = instance env texp.exp_type}
+      and ty_fun = instance env ty_fun' in
       if not (simple_res || no_labels ty_res) then begin
         unify_exp env texp ty_expected;
         texp
@@ -1728,7 +2368,8 @@ and type_argument env sarg ty_expected' =
         {pat_desc = Tpat_var id; pat_type = ty;
          pat_loc = Location.none; pat_env = env},
         {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc =
-         Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})}
+         Texp_ident(Path.Pident id, {val_type = ty; val_kind = Val_reg;
+                                     val_loc = Location.none})}
       in
       let eta_pat, eta_var = var_pair "eta" ty_arg in
       let func texp =
@@ -1746,7 +2387,9 @@ and type_argument env sarg ty_expected' =
            Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
       end
   | _ ->
-      type_expect env sarg ty_expected
+      let texp = type_expect env sarg ty_expected' in
+      unify_exp env texp ty_expected;
+      texp
 
 and type_application env funct sargs =
   (* funct.exp_type may be generic *)
@@ -1765,12 +2408,12 @@ and type_application env funct sargs =
         (List.map
            (function None, x -> None, x | Some f, x -> Some (f ()), x)
            (List.rev args),
-         instance (result_type omitted ty_fun))
+         instance env (result_type omitted ty_fun))
     | (l1, sarg1) :: sargl ->
         let (ty1, ty2) =
           let ty_fun = expand_head env ty_fun in
           match ty_fun.desc with
-            Tvar ->
+            Tvar _ ->
               let t1 = newvar () and t2 = newvar () in
               let not_identity = function
                   Texp_ident(_,{val_kind=Val_prim
@@ -1822,9 +2465,10 @@ and type_application env funct sargs =
     end
   in
   let warned = ref false in
-  let rec type_args args omitted ty_fun ty_old sargs more_sargs =
-    match expand_head env ty_fun with
-      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
+  let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
       when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
         let may_warn loc w =
           if not !warned && !Clflags.principal && lv <> generic_level
@@ -1845,7 +2489,8 @@ and type_application env funct sargs =
                 if l <> l' && l' <> "" then
                   raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
                 else
-                  ([], more_sargs, Some (fun () -> type_argument env sarg0 ty))
+                  ([], more_sargs,
+                   Some (fun () -> type_argument env sarg0 ty ty0))
             | _ ->
                 assert false
           end else try
@@ -1866,12 +2511,13 @@ and type_application env funct sargs =
             in
             sargs, more_sargs,
             if optional = Required || is_optional l' then
-              Some (fun () -> type_argument env sarg0 ty)
+              Some (fun () -> type_argument env sarg0 ty ty0)
             else begin
               may_warn sarg0.pexp_loc
                 (Warnings.Not_principal "using an optional argument here");
               Some (fun () -> option_some (type_argument env sarg0
-                                             (extract_option_type env ty)))
+                                             (extract_option_type env ty)
+                                             (extract_option_type env ty0)))
             end
           with Not_found ->
             sargs, more_sargs,
@@ -1881,7 +2527,7 @@ and type_application env funct sargs =
               may_warn funct.exp_loc
                 (Warnings.Without_principality "eliminated optional argument");
               ignored := (l,ty,lv) :: !ignored;
-              Some (fun () -> option_none (instance ty) Location.none)
+              Some (fun () -> option_none (instance env ty) Location.none)
             end else begin
               may_warn funct.exp_loc
                 (Warnings.Without_principality "commuted an argument");
@@ -1891,25 +2537,26 @@ and type_application env funct sargs =
         let omitted =
           if arg = None then (l,ty,lv) :: omitted else omitted in
         let ty_old = if sargs = [] then ty_fun else ty_old in
-        type_args ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs
+        type_args ((arg,optional)::args) omitted ty_fun ty_fun0
+          ty_old sargs more_sargs
     | _ ->
         match sargs with
           (l, sarg0) :: _ when ignore_labels ->
             raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
         | _ ->
-            type_unknown_args args omitted (instance ty_fun)
+            type_unknown_args args omitted ty_fun0
               (sargs @ more_sargs)
   in
   match funct.exp_desc, sargs with
     (* Special case for ignore: avoid discarding warning *)
     Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
     ["", sarg] ->
-      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) "" in
+      let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in
       let exp = type_expect env sarg ty_arg in
       begin match (expand_head env exp.exp_type).desc with
       | Tarrow _ ->
           Location.prerr_warning exp.exp_loc Warnings.Partial_application
-      | Tvar ->
+      | Tvar _ ->
           add_delayed_check (fun () -> check_application_result env false exp)
       | _ -> ()
       end;
@@ -1917,12 +2564,13 @@ and type_application env funct sargs =
   | _ ->
       let ty = funct.exp_type in
       if ignore_labels then
-        type_args [] [] ty ty [] sargs
+        type_args [] [] ty (instance env ty) ty [] sargs
       else
-        type_args [] [] ty ty sargs []
+        type_args [] [] ty (instance env ty) ty sargs []
 
 and type_construct env loc lid sarg explicit_arity ty_expected =
   let constr = Typetexp.find_constructor env loc lid in
+  Env.mark_constructor `Positive env (Longident.last lid) constr;
   let sargs =
     match sarg with
       None -> []
@@ -1932,188 +2580,36 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
   if List.length sargs <> constr.cstr_arity then
     raise(Error(loc, Constructor_arity_mismatch
                   (lid, constr.cstr_arity, List.length sargs)));
-  if !Clflags.principal then begin_def ();
+  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
-  if !Clflags.principal then begin
-    end_def ();
-    List.iter generalize_structure ty_args;
-    generalize_structure ty_res
-  end;
   let texp =
     re {
       exp_desc = Texp_construct(constr, []);
       exp_loc = loc;
-      exp_type = instance ty_res;
+      exp_type = ty_res;
       exp_env = env } in
-  unify_exp env texp ty_expected;
-  let args = List.map2 (type_argument env) sargs ty_args in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    unify_exp env {texp with exp_type = instance_def ty_res}
+                  (instance env ty_expected);
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list env (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance env ty_expected);
+  let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs
+      (List.combine ty_args ty_args0) in
   if constr.cstr_private = Private then
     raise(Error(loc, Private_type ty_res));
-  { texp with exp_desc = Texp_construct(constr, args) }
-
-(* Typing of an expression with an expected type.
-   Some constructs are treated specially to provide better error messages. *)
-
-and type_expect ?in_function env sexp ty_expected =
-  let loc = sexp.pexp_loc in
-  match sexp.pexp_desc with
-    Pexp_constant(Const_string s as cst) ->
-      let exp =
-        re {
-          exp_desc = Texp_constant cst;
-          exp_loc = loc;
-          exp_type =
-            (* Terrible hack for format strings *)
-            begin match (repr (expand_head env ty_expected)).desc with
-              Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
-                type_format loc s
-            | _ -> instance Predef.type_string
-            end;
-          exp_env = env } in
-      unify_exp env exp ty_expected;
-      exp
-  | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct env loc lid sarg explicit_arity ty_expected
-  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
-      let body = type_expect new_env sbody ty_expected in
-      re {
-        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
-        exp_loc = loc;
-        exp_type = body.exp_type;
-        exp_env = env }
-  | Pexp_sequence(sexp1, sexp2) ->
-      let exp1 = type_statement env sexp1 in
-      let exp2 = type_expect env sexp2 ty_expected in
-      re {
-        exp_desc = Texp_sequence(exp1, exp2);
-        exp_loc = loc;
-        exp_type = exp2.exp_type;
-        exp_env = env }
-  | Pexp_function (l, Some default, [spat, sbody]) ->
-      let default_loc = default.pexp_loc in
-      let scases = [
-         {ppat_loc = default_loc;
-          ppat_desc =
-            Ppat_construct
-              (Longident.(Ldot (Lident "*predef*", "Some")),
-               Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"},
-               false)},
-         {pexp_loc = default_loc;
-          pexp_desc = Pexp_ident(Longident.Lident "*sth*")};
-         {ppat_loc = default_loc;
-          ppat_desc = Ppat_construct
-            (Longident.(Ldot (Lident "*predef*", "None")), None, false)},
-         default;
-      ] in
-      let smatch = {
-        pexp_loc = loc;
-        pexp_desc =
-          Pexp_match ({
-            pexp_loc = loc;
-            pexp_desc =
-              Pexp_ident(Longident.Lident "*opt*")
-            },
-            scases
-          )
-      } in
-      let sfun = {
-        pexp_loc = loc;
-        pexp_desc =
-         Pexp_function (
-           l,
-           None,
-           [ {ppat_loc = loc;
-              ppat_desc = Ppat_var "*opt*"},
-             {pexp_loc = loc;
-              pexp_desc =
-                Pexp_let(Default, [spat, smatch], sbody);
-             }
-           ]
-         )
-      } in
-      type_expect ?in_function env sfun ty_expected
-  | Pexp_function (l, _, caselist) ->
-      let (loc_fun, ty_fun) =
-        match in_function with Some p -> p
-        | None -> (loc, ty_expected)
-      in
-      let (ty_arg, ty_res) =
-        try filter_arrow env ty_expected l
-        with Unify _ ->
-          match expand_head env ty_expected with
-            {desc = Tarrow _} as ty ->
-              raise(Error(loc, Abstract_wrong_label(l, ty)))
-          | _ ->
-              raise(Error(loc_fun,
-                          Too_many_arguments (in_function <> None, ty_fun)))
-      in
-      let ty_arg =
-        if is_optional l then
-          let tv = newvar() in
-          begin
-            try unify env ty_arg (type_option tv)
-            with Unify _ -> assert false
-          end;
-          type_option tv
-        else ty_arg
-      in
-      let cases, partial =
-        type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
-          (Some loc) caselist in
-      let not_function ty =
-        let ls, tvar = list_labels env ty in
-        ls = [] && not tvar
-      in
-      if is_optional l && not_function ty_res then
-        Location.prerr_warning (fst (List.hd cases)).pat_loc
-          Warnings.Unerasable_optional_argument;
-      re {
-        exp_desc = Texp_function(cases, partial);
-        exp_loc = loc;
-        exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
-        exp_env = env }
-  | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
-      let body = type_expect env sbody ty_expected in
-      re {
-        exp_desc = Texp_when(cond, body);
-        exp_loc = loc;
-        exp_type = body.exp_type;
-        exp_env = env }
-  | Pexp_poly(sbody, sty) ->
-      let ty =
-        match sty with None -> repr ty_expected
-        | Some sty ->
-            let ty = Typetexp.transl_simple_type env false sty in
-            repr ty
-      in
-      let set_type ty =
-        unify_exp env
-          { exp_desc = Texp_tuple [];
-            exp_loc = loc;
-            exp_type = ty; exp_env = env } ty_expected in
-      begin
-        match ty.desc with
-          Tpoly (ty', []) ->
-            if sty <> None then set_type ty;
-            let exp = type_expect env sbody ty' in
-            re { exp with exp_type = ty }
-        | Tpoly (ty', tl) ->
-            if sty <> None then set_type ty;
-            (* One more level to generalize locally *)
-            begin_def ();
-            let vars, ty'' = instance_poly true tl ty' in
-            let exp = type_expect env sbody ty'' in
-            end_def ();
-            check_univars env false "method" exp ty_expected vars;
-            re { exp with exp_type = ty }
-        | _ -> assert false
-      end
-  | _ ->
-      let exp = type_exp env sexp in
-      unify_exp env exp ty_expected;
-      exp
+  { texp with exp_desc = Texp_construct(constr, args)}
 
 (* Typing of statements (expressions whose values are discarded) *)
 
@@ -2123,7 +2619,7 @@ and type_statement env sexp =
   let exp = type_exp env sexp in
   end_def();
   if !Clflags.strict_sequence then
-    let expected_ty = instance Predef.type_unit in
+    let expected_ty = instance_def Predef.type_unit in
     unify_exp env exp expected_ty;
     exp else
   let ty = expand_head env exp.exp_type and tv = newvar() in
@@ -2131,9 +2627,9 @@ and type_statement env sexp =
   | Tarrow _ ->
       Location.prerr_warning loc Warnings.Partial_application
   | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
-  | Tvar when ty.level > tv.level ->
+  | Tvar _ when ty.level > tv.level ->
       Location.prerr_warning loc Warnings.Nonreturning_statement
-  | Tvar ->
+  | Tvar _ ->
       add_delayed_check (fun () -> check_application_result env true exp)
   | _ ->
       Location.prerr_warning loc Warnings.Statement_type
@@ -2143,26 +2639,58 @@ and type_statement env sexp =
 
 (* Typing of match cases *)
 
-and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
+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
+  (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
+  let ty_arg, 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
+  let lev, env =
+    if has_gadts then begin
+      (* raise level for existentials *)
+      begin_def ();
+      Ident.set_current_time (get_current_level ()); 
+      let lev = Ident.current_time () in
+      Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
+      (lev, Env.add_gadt_instance_level lev env)
+    end else (get_current_level (), env)
+  in
+  (* if has_gadts then
+    Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res;*)
+  begin_def (); (* propagation of the argument *)
   let ty_arg' = newvar () in
   let pattern_force = ref [] in
+  (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
   let pat_env_list =
     List.map
       (fun (spat, sexp) ->
         let loc = sexp.pexp_loc in
-        if !Clflags.principal then begin_def ();
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
         let scope = Some (Annot.Idef loc) in
-        let (pat, ext_env, force) = type_pattern env spat scope 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
+        in
         pattern_force := force @ !pattern_force;
         let pat =
           if !Clflags.principal then begin
             end_def ();
             iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
-            { pat with pat_type = instance pat.pat_type }
+            { pat with pat_type = instance env pat.pat_type }
           end else pat
         in
         unify_pat env pat ty_arg';
-        (pat, ext_env))
+        (pat, (ext_env, unpacks)))
       caselist in
   (* Check for polymorphic variants to close *)
   let patl = List.map fst pat_env_list in
@@ -2172,76 +2700,202 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
   end;
   (* `Contaminating' unifications start here *)
   List.iter (fun f -> f()) !pattern_force;
-  begin match pat_env_list with [] -> ()
-  | (pat, _) :: _ -> unify_pat env pat ty_arg
-  end;
+  (* Post-processing and generalization *)
+  let patl = List.map fst pat_env_list in
+  List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
+    patl;
+  List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;
+  end_def ();
+  List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
+  (* type bodies *)
   let in_function = if List.length caselist = 1 then in_function else None in
   let cases =
     List.map2
-      (fun (pat, ext_env) (spat, sexp) ->
-        let exp = type_expect ?in_function ext_env sexp ty_res in
-        (pat, exp))
+      (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
+        let sexp = wrap_unpacks sexp unpacks in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true env ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt env spat then correct_levels ty_res
+          else ty_res in
+        (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
+          Printtyp.raw_type_expr ty_res'; *)
+        let exp = type_expect ?in_function ext_env sexp ty_res' in
+        (pat, {exp with exp_type = instance env ty_res'}))
       pat_env_list caselist
   in
+  if !Clflags.principal || has_gadts then begin
+    let ty_res' = instance env ty_res in
+    List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
+  end;
   let partial =
-    match partial_loc with
-    | None -> Partial
-    | Some partial_loc -> Parmatch.check_partial partial_loc cases
+    if partial_flag then
+      Parmatch.check_partial_gadt (partial_pred ~lev env ty_arg) loc cases
+    else
+      Partial
   in
   add_delayed_check (fun () -> Parmatch.check_unused env cases);
+  if has_gadts then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance env ty_res) (newvar ()) ;
+  end;
   cases, partial
 
 (* Typing of let bindings *)
 
-and type_let env rec_flag spat_sexp_list scope =
+and type_let ?(check = fun s -> Warnings.Unused_var s)
+             ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    env rec_flag spat_sexp_list scope allow =
   begin_def();
   if !Clflags.principal then begin_def ();
-  let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
-  let (pat_list, new_env, force) = type_pattern_list env spatl scope in
-  if rec_flag = Recursive then
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [_, {pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident(Longident.Lident "*opt*")},_)}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun (spat, sexp) ->
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_constraint (_, _, Some sty)
+        | _, Pexp_constraint (_, Some sty, None) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            {ppat_desc = Ppat_constraint (spat, sty);
+             ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}}
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, unpacks) =
+    type_pattern_list env spatl scope nvs allow in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
     List.iter2
       (fun pat (_, sexp) ->
         let pat =
           match pat.pat_type.desc with
           | Tpoly (ty, tl) ->
-              {pat with pat_type = snd (instance_poly false tl ty)}
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
           | _ -> pat
         in unify_pat env pat (type_approx env sexp))
       pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        iter_pattern finalize_variant pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
   let pat_list =
     if !Clflags.principal then begin
       end_def ();
       List.map
         (fun pat ->
           iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
-          {pat with pat_type = instance pat.pat_type})
+          {pat with pat_type = instance env pat.pat_type})
         pat_list
     end else pat_list in
-  (* Polymoprhic variant processing *)
-  List.iter
-    (fun pat ->
-      if has_variants pat then begin
-        Parmatch.pressure_variants env [pat];
-        iter_pattern finalize_variant pat
-      end)
-    pat_list;
   (* Only bind pattern variables after generalizing *)
   List.iter (fun f -> f()) force;
   let exp_env =
-    match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
+    if is_recursive then new_env else env in
+
+  let current_slot = ref None in
+  let warn_unused =
+    Warnings.is_active (check "") || Warnings.is_active (check_strict "") in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = Mone),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map
+      (fun pat ->
+        if not warn_unused then pat, None
+        else
+          let some_used = ref false in
+            (* has one of the identifier of this pattern been used? *)
+          let slot = ref [] in
+          List.iter
+            (fun id ->
+              let vd = Env.find_value (Path.Pident id) new_env in
+              (* note: Env.find_value does not trigger the value_used event *)
+              let name = Ident.name id in
+              let used = ref false in
+              if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                add_delayed_check
+                  (fun () ->
+                    if not !used then
+                      Location.prerr_warning vd.val_loc
+                        ((if !some_used then check_strict else check) name)
+                  );
+              Env.set_value_used_callback
+                name vd
+                (fun () ->
+                  match !current_slot with
+                  | Some slot -> slot := (name, vd) :: !slot
+                  | None ->
+                      List.iter
+                        (fun (name, vd) -> Env.mark_value_used name vd)
+                        (get_ref slot);
+                      used := true;
+                      some_used := true
+                )
+            )
+            (Typedtree.pat_bound_idents pat);
+          pat, Some slot
+        )
+      pat_list
+  in
   let exp_list =
     List.map2
-      (fun (spat, sexp) pat ->
+      (fun (spat, sexp) (pat, slot) ->
+        let sexp =
+          if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
+        if is_recursive then current_slot := slot;
         match pat.pat_type.desc with
         | Tpoly (ty, tl) ->
             begin_def ();
-            let vars, ty' = instance_poly true tl ty in
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
             let exp = type_expect exp_env sexp ty' in
             end_def ();
             check_univars env true "definition" exp pat.pat_type vars;
-            {exp with exp_type = instance exp.exp_type}
+            {exp with exp_type = instance env exp.exp_type}
         | _ -> type_expect exp_env sexp pat.pat_type)
-      spat_sexp_list pat_list in
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
   List.iter2
     (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
     pat_list exp_list;
@@ -2254,13 +2908,24 @@ and type_let env rec_flag spat_sexp_list scope =
   List.iter
     (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
     pat_list;
-  (List.combine pat_list exp_list, new_env)
+  (List.combine pat_list exp_list, new_env, unpacks)
 
 (* Typing of toplevel bindings *)
 
 let type_binding env rec_flag spat_sexp_list scope =
   Typetexp.reset_type_variables();
-  type_let env rec_flag spat_sexp_list scope
+  let (pat_exp_list, new_env, unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      env rec_flag spat_sexp_list scope false
+  in
+  (pat_exp_list, new_env)
+
+let type_let env rec_flag spat_sexp_list scope =
+  let (pat_exp_list, new_env, unpacks) =
+    type_let env rec_flag spat_sexp_list scope false in
+  (pat_exp_list, new_env)
 
 (* Typing of toplevel expressions *)
 
@@ -2271,7 +2936,12 @@ let type_expression env sexp =
   end_def();
   if is_nonexpansive exp then generalize exp.exp_type
   else generalize_expansive env exp.exp_type;
-  exp
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (path, desc) = Env.lookup_value lid env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
 
 (* Error report *)
 
@@ -2426,3 +3096,24 @@ let report_error ppf = function
       report_unification_error ppf trace
         (fun ppf -> fprintf ppf "This %s has type" kind)
         (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      fprintf ppf "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      fprintf ppf
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is packed module, but the expected type is@ %a"
+        type_expr ty
+  | Recursive_local_constraint trace ->
+      report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "Recursive local constraint when unifying")
+        (function ppf ->
+           fprintf ppf "with")
+  | Unexpected_existential ->
+      fprintf ppf
+        "Unexpected existential"
+
+let () =
+  Env.add_delayed_check_forward := add_delayed_check
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3fb90ff3..8b9ce86f 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,12 +51,14 @@ val type_exp:
 val type_approx:
         Env.t -> Parsetree.expression -> type_expr
 val type_argument:
-        Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
 
 val option_some: Typedtree.expression -> Typedtree.expression
 val option_none: type_expr -> Location.t -> Typedtree.expression
 val extract_option_type: Env.t -> type_expr -> type_expr
 val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
+val generalizable: int -> type_expr -> bool
 val reset_delayed_checks: unit -> unit
 val force_delayed_checks: unit -> unit
 
@@ -96,6 +98,11 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Recursive_local_constraint of (type_expr * type_expr) list
+  | Unexpected_existential
 
 exception Error of Location.t * error
 
@@ -109,5 +116,8 @@ val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref
 val type_object:
   (Env.t -> Location.t -> Parsetree.class_structure ->
    Typedtree.class_structure * class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> type_expr list ->
+   Typedtree.module_expr * type_expr list) ref
 
 val create_package_type: Location.t -> Env.t -> Parsetree.package_type -> type_expr
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index f8a58181..cfcf5512 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -30,7 +30,7 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr * Includecore.type_mismatch list
   | Constraint_failed of type_expr * type_expr
-  | Unconsistent_constraint of (type_expr * type_expr) list
+  | Inconsistent_constraint of (type_expr * type_expr) list
   | Type_clash of (type_expr * type_expr) list
   | Parameters_differ of Path.t * type_expr * type_expr
   | Null_arity_external
@@ -42,6 +42,7 @@ type error =
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
+  | Varying_anonymous
 
 exception Error of Location.t * error
 
@@ -58,6 +59,8 @@ let enter_type env (name, sdecl) id =
         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_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
     }
   in
   Env.add_type id decl env
@@ -109,7 +112,7 @@ let set_fixed_row env loc p decl =
     | _ ->
         raise (Error (loc, Bad_fixed_type "is not an object or variant"))
   in
-  if rv.desc <> Tvar then
+  if not (Btype.is_Tvar rv) then
     raise (Error (loc, Bad_fixed_type "has no row variable"));
   rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
 
@@ -121,15 +124,21 @@ module StringSet =
     let compare = compare
   end)
 
+let make_params sdecl =
+  try 
+    List.map 
+      (function
+	  None -> Ctype.new_global_var ~name:"_" ()
+	| Some x -> enter_type_variable true sdecl.ptype_loc x)
+      sdecl.ptype_params
+  with Already_bound ->
+    raise(Error(sdecl.ptype_loc, Repeated_parameter))
+
 let transl_declaration env (name, sdecl) id =
   (* Bind type parameters *)
   reset_type_variables();
   Ctype.begin_def ();
-  let params =
-    try List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
-    with Already_bound ->
-      raise(Error(sdecl.ptype_loc, Repeated_parameter))
-  in
+  let params = make_params sdecl in
   let cstrs = List.map
       (fun (sty, sty', loc) ->
         transl_simple_type env false sty,
@@ -145,19 +154,38 @@ let transl_declaration env (name, sdecl) id =
         | Ptype_variant cstrs ->
             let all_constrs = ref StringSet.empty in
             List.iter
-              (fun (name, args, loc) ->
+              (fun (name, _, _, loc) ->
                 if StringSet.mem name !all_constrs then
                   raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
                 all_constrs := StringSet.add name !all_constrs)
               cstrs;
-            if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
-               > (Config.max_tag + 1) then
+            if List.length
+		(List.filter (fun (_, args, _, _) -> args <> []) cstrs)
+		> (Config.max_tag + 1) then
               raise(Error(sdecl.ptype_loc, Too_many_constructors));
-            Type_variant
-              (List.map
-                 (fun (name, args, loc) ->
-                    (name, List.map (transl_simple_type env true) args))
-              cstrs)
+	    let make_cstr (name, args, ret_type, loc) =
+	      match ret_type with
+	      | None ->
+		  (name, List.map (transl_simple_type env true) args, None)
+	      | Some sty -> 
+                (* if it's a generalized constructor we must first narrow and
+                   then widen so as to not introduce any new constraints *)
+		  let z = narrow () in 
+		  reset_type_variables ();
+		  let args = List.map (transl_simple_type env false) args in 
+		  let ret_type =
+                    let ty = transl_simple_type env false sty in
+                    let p = Path.Pident id in
+                    match (Ctype.repr ty).desc with
+                      Tconstr (p', _, _) when Path.same p p' -> ty
+                    | _ -> raise(Error(sty.ptyp_loc,
+                             Constraint_failed (ty, Ctype.newconstr p params)))
+		  in
+		  widen z;
+		  (name, args, Some ret_type)
+  	    in
+	    Type_variant (List.map make_cstr cstrs)
+	    
         | Ptype_record lbls ->
             let all_labels = ref StringSet.empty in
             List.iter
@@ -187,13 +215,15 @@ let transl_declaration env (name, sdecl) id =
             Some (transl_simple_type env no_row sty)
         end;
       type_variance = List.map (fun _ -> true, true, true) params;
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
     } in
 
   (* Check constraints *)
   List.iter
     (fun (ty, ty', loc) ->
       try Ctype.unify env ty ty' with Ctype.Unify tr ->
-        raise(Error(loc, Unconsistent_constraint tr)))
+        raise(Error(loc, Inconsistent_constraint tr)))
     cstrs;
   Ctype.end_def ();
   (* Add abstract row *)
@@ -219,7 +249,11 @@ let generalize_decl decl =
     Type_abstract ->
       ()
   | Type_variant v ->
-      List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
+      List.iter
+	(fun (_, tyl, ret_type) ->
+	  List.iter Ctype.generalize tyl;
+	  may Ctype.generalize ret_type)
+	v
   | Type_record(r, rep) ->
       List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
   end;
@@ -230,12 +264,7 @@ let generalize_decl decl =
 
 (* Check that all constraints are enforced *)
 
-module TypeSet =
-  Set.Make
-    (struct
-      type t = type_expr
-      let compare t1 t2 = t1.id - t2.id
-    end)
+module TypeSet = Btype.TypeSet
 
 let rec check_constraints_rec env loc visited ty =
   let ty = Ctype.repr ty in
@@ -270,15 +299,23 @@ let check_constraints env (_, sdecl) (_, decl) =
       in
       let pl = find_pl sdecl.ptype_kind in
       List.iter
-        (fun (name, tyl) ->
-          let styl =
-            try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
+        (fun (name, tyl, ret_type) ->
+          let (styl, sret_type) =
+            try
+	      let (_, sty, sret_type, _) =
+		List.find (fun (n,_,_,_) -> n = name)  pl
+	      in (sty, sret_type)
             with Not_found -> assert false in
           List.iter2
             (fun sty ty ->
               check_constraints_rec env sty.ptyp_loc visited ty)
-            styl tyl)
-        l
+            styl tyl;
+	  match sret_type, ret_type with
+	  | Some sr, Some r ->
+	      check_constraints_rec env sr.ptyp_loc visited r
+	  | _ ->
+	      () )
+	l
   | Type_record (l, _) ->
       let rec find_pl = function
           Ptype_record pl -> pl
@@ -322,8 +359,10 @@ let check_abbrev env (_, sdecl) (id, decl) =
               else if not (Ctype.equal env false args decl.type_params)
               then [Includecore.Constraint]
               else
-                Includecore.type_declarations env id
+                Includecore.type_declarations env
+                  (Path.last path)
                   decl'
+                  id
                   (Subst.type_declaration
                      (Subst.add_type id path Subst.identity) decl)
             in
@@ -364,7 +403,7 @@ let check_recursion env loc path decl to_check =
           else if to_check path' && not (List.mem path' prev_exp) then begin
             try
               (* Attempt expansion *)
-              let (params0, body0) = Env.find_type_expansion path' env in
+              let (params0, body0, _) = Env.find_type_expansion path' env in
               let (params, body) =
                 Ctype.instance_parameterized_type params0 body0 in
               begin
@@ -463,7 +502,7 @@ let compute_variance env tvl nega posi cntr ty =
           compute_same row.row_more
       | Tpoly (ty, _) ->
           compute_same ty
-      | Tvar | Tnil | Tlink _ | Tunivar -> ()
+      | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
       | Tpackage (_, _, tyl) ->
           List.iter (compute_variance_rec true true true) tyl
     end
@@ -481,7 +520,7 @@ let whole_type decl =
   match decl.type_kind with
     Type_variant tll ->
       Btype.newgenty
-        (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll))
+        (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll)) 
   | Type_record (ftl, _) ->
       Btype.newgenty
         (Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
@@ -490,43 +529,23 @@ let whole_type decl =
         Some ty -> ty
       | _ -> Btype.newgenty (Ttuple [])
 
-let compute_variance_decl env check decl (required, loc) =
-  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))
-      required
-  else
+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 fvl = if check then Ctype.free_variables (whole_type decl) else [] 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
-  begin match decl.type_kind with
-    Type_abstract ->
-      begin match decl.type_manifest with
-        None -> assert false
-      | Some ty -> compute_variance env tvl true false false ty
-      end
-  | Type_variant tll ->
-      List.iter
-        (fun (_,tl) ->
-          List.iter (compute_variance env tvl true false false) tl)
-        tll
-  | Type_record (ftl, _) ->
-      List.iter
-        (fun (_, mut, ty) ->
-          let cn = (mut = Mutable) in
-          compute_variance env tvl true cn cn ty)
-        ftl
-  end;
+  List.iter (fun (cn,ty) -> compute_variance env tvl true cn cn ty) tyl;
   let required =
     List.map (fun (c,n as r) -> if c || n then r else (true,true))
       required
   in
   List.iter2
     (fun (ty, co, cn, ct) (c, n) ->
-      if ty.desc <> Tvar then begin
+      if not (Btype.is_Tvar ty) then begin
         co := c; cn := n; ct := n;
         compute_variance env tvl2 c n n ty
       end)
@@ -534,10 +553,7 @@ let compute_variance_decl env check decl (required, loc) =
   List.iter2
     (fun (ty, c1, n1, t1) (_, c2, n2, t2) ->
       if !c1 && not !c2 || !n1 && not !n2
-      (* || !t1 && not !t2 && decl.type_kind = Type_abstract *)
-      then raise (Error(loc,
-                        if not (!c2 || !n2) then Unbound_type_var (ty, decl)
-                        else Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
+      then raise (Error(loc, Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
     tvl1 tvl2;
   let pos = ref 0 in
   List.map2
@@ -550,6 +566,65 @@ let compute_variance_decl env check decl (required, loc) =
       (!co, !cn, !ct))
     tvl0 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
+
+let compute_variance_gadt env check (required, loc as rloc) decl
+    (_, tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env check rloc {decl with type_private = Private}
+        (add_false tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (path, tyl, _)} ->
+          let fvl = List.map Ctype.free_variables tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained env (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (add_false tl)
+      | _ -> assert false
+            
+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))
+      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
+  | 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)))
+      else begin
+        match List.map (compute_variance_gadt env check rloc decl) tll with
+        | vari :: _ -> vari
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env check rloc decl
+        (List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
+
 let is_sharp id =
   let s = Ident.name id in
   String.length s > 0 && s.[0] = '#'
@@ -612,7 +687,7 @@ let check_duplicates name_sdecl_list =
     (fun (name, sdecl) -> match sdecl.ptype_kind with
       Ptype_variant cl ->
         List.iter
-          (fun (cname, _, loc) ->
+          (fun (cname, _, _, loc) ->
             try
               let name' = Hashtbl.find constrs cname in
               Location.prerr_warning loc
@@ -676,8 +751,28 @@ let transl_type_decl env name_sdecl_list =
   (* Enter types. *)
   let temp_env = List.fold_left2 enter_type env name_sdecl_list id_list in
   (* Translate each declaration. *)
-  let decls =
-    List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let id_slots id =
+    if not warn_unused then id, None
+    else
+      (* See typecore.ml for a description of the algorithm used
+         to detect unused declarations in a set of recursive definitions. *)
+      let slot = ref [] in
+      let td = Env.find_type (Path.Pident id) temp_env in
+      let name = Ident.name id in
+      Env.set_type_used_callback
+        name td
+        (fun old_callback ->
+          match !current_slot with
+          | Some slot -> slot := (name, td) :: !slot
+          | None -> List.iter (fun (name, d) -> Env.mark_type_used name d) (get_ref slot); old_callback ()
+        );
+      id, Some slot
+  in
+  let transl_declaration name_sdecl (id, slot) = current_slot := slot; transl_declaration temp_env name_sdecl id in
+  let decls = List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in
+  current_slot := None;
   (* Check for duplicates *)
   check_duplicates name_sdecl_list;
   (* Build the final env. *)
@@ -733,13 +828,14 @@ let transl_closed_type env sty =
   | []      -> ty
   | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty)))
 
-let transl_exception env excdecl =
+let transl_exception env loc excdecl =
   reset_type_variables();
   Ctype.begin_def();
   let types = List.map (transl_closed_type env) excdecl in
   Ctype.end_def();
   List.iter Ctype.generalize types;
-  types
+  { exn_args = types;
+    exn_loc = loc }
 
 (* Translate an exception rebinding *)
 let transl_exn_rebind env loc lid =
@@ -748,16 +844,18 @@ let transl_exn_rebind env loc lid =
       Env.lookup_constructor lid env
     with Not_found ->
       raise(Error(loc, Unbound_exception lid)) in
+  Env.mark_constructor `Positive env (Longident.last lid) cdescr;
   match cdescr.cstr_tag with
-    Cstr_exception path -> (path, cdescr.cstr_args)
+    Cstr_exception (path, _) ->
+      (path, {exn_args = cdescr.cstr_args; exn_loc = loc})
   | _ -> raise(Error(loc, Not_an_exception lid))
 
 (* Translate a value declaration *)
-let transl_value_decl env valdecl =
+let transl_value_decl env loc valdecl =
   let ty = Typetexp.transl_type_scheme env valdecl.pval_type in
   match valdecl.pval_prim with
     [] ->
-      { val_type = ty; val_kind = Val_reg }
+      { val_type = ty; val_kind = Val_reg; val_loc = loc }
   | decl ->
       let arity = Ctype.arity ty in
       if arity = 0 then
@@ -767,18 +865,14 @@ let transl_value_decl env valdecl =
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
-      { val_type = ty; val_kind = Val_prim prim }
+      { val_type = ty; val_kind = Val_prim prim; val_loc = loc }
 
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)
 let transl_with_constraint env id row_path orig_decl sdecl =
   reset_type_variables();
   Ctype.begin_def();
-  let params =
-    try
-      List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
-    with Already_bound ->
-      raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
+  let params = make_params sdecl in
   let orig_decl = Ctype.instance_declaration orig_decl in
   let arity_ok = List.length params = orig_decl.type_arity in
   if arity_ok then
@@ -789,7 +883,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
          Ctype.unify env (transl_simple_type env false ty)
                          (transl_simple_type env false ty')
        with Ctype.Unify tr ->
-         raise(Error(loc, Unconsistent_constraint tr)))
+         raise(Error(loc, Inconsistent_constraint tr)))
     sdecl.ptype_cstrs;
   let no_row = not (is_fixed_type sdecl) in
   let decl =
@@ -804,6 +898,8 @@ let transl_with_constraint env id row_path orig_decl sdecl =
             Some(transl_simple_type env no_row sty)
         end;
       type_variance = [];
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
     }
   in
   begin match row_path with None -> ()
@@ -833,7 +929,10 @@ let abstract_type_decl arity =
       type_kind = Type_abstract;
       type_private = Public;
       type_manifest = None;
-      type_variance = replicate_list (true, true, true) arity } in
+      type_variance = replicate_list (true, true, true) arity;
+      type_newtype_level = None;
+      type_loc = Location.none;
+     } in
   Ctype.end_def();
   generalize_decl decl;
   decl
@@ -912,10 +1011,10 @@ let report_error ppf = function
         (Includecore.report_type_mismatch "the original" "this" "definition")
         errs
   | Constraint_failed (ty, ty') ->
-      fprintf ppf "Constraints are not satisfied in this type.@.";
       Printtyp.reset_and_mark_loops ty;
       Printtyp.mark_loops ty';
-      fprintf ppf "@[Type@ %a@ should be an instance of@ %a@]"
+      fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]"
+        "Constraints are not satisfied in this type."
         Printtyp.type_expr ty Printtyp.type_expr ty'
   | Parameters_differ (path, ty, ty') ->
       Printtyp.reset_and_mark_loops ty;
@@ -923,7 +1022,7 @@ 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'
-  | Unconsistent_constraint trace ->
+  | Inconsistent_constraint trace ->
       fprintf ppf "The type constraints are not consistent.@.";
       Printtyp.report_unification_error ppf trace
         (fun ppf -> fprintf ppf "Type")
@@ -944,9 +1043,10 @@ let report_error ppf = function
       fprintf ppf "A type variable is unbound in this type declaration";
       let ty = Ctype.repr ty in
       begin match decl.type_kind, decl.type_manifest with
-        Type_variant tl, _ ->
-          explain_unbound ppf ty tl (fun (_,tl) -> Btype.newgenty (Ttuple tl))
-            "case" (fun (lab,_) -> lab ^ " of ")
+      | Type_variant tl, _ ->
+          explain_unbound ppf ty tl (fun (_,tl,_) -> 
+	    Btype.newgenty (Ttuple tl)) 
+            "case" (fun (lab,_,_) -> lab ^ " of ") 
       | Type_record (tl, _), _ ->
           explain_unbound ppf ty tl (fun (_,_,t) -> t)
             "field" (fun (lab,_,_) -> lab ^ ": ")
@@ -978,12 +1078,11 @@ let report_error ppf = function
         | _ -> "th"
       in
       if n < 1 then
-        fprintf ppf "%s@ %s@ %s"
-          "In this definition, a type variable"
-          "has a variance that is not reflected"
-          "by its occurrence in type parameters."
+        fprintf ppf "@[%s@ %s@]"
+          "In this definition, a type variable has a variance that"
+          "is not reflected by its occurrence in type parameters."
       else
-        fprintf ppf "%s@ %s@ %s %d%s %s %s,@ %s %s"
+        fprintf ppf "@[%s@ %s@ %s %d%s %s %s,@ %s %s@]"
           "In this definition, expected parameter"
           "variances are not satisfied."
           "The" n (suffix n)
@@ -993,3 +1092,7 @@ let report_error ppf = function
       fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
   | Bad_fixed_type r ->
       fprintf ppf "This fixed type %s" r
+  | Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index f0e742bd..36b0aac6 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -21,13 +21,13 @@ val transl_type_decl:
     Env.t -> (string * Parsetree.type_declaration) list ->
                                   (Ident.t * type_declaration) list * Env.t
 val transl_exception:
-    Env.t -> Parsetree.exception_declaration -> exception_declaration
+    Env.t -> Location.t -> Parsetree.exception_declaration -> exception_declaration
 
 val transl_exn_rebind:
     Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
 
 val transl_value_decl:
-    Env.t -> Parsetree.value_description -> value_description
+    Env.t -> Location.t -> Parsetree.value_description -> value_description
 
 val transl_with_constraint:
     Env.t -> Ident.t -> Path.t option -> type_declaration ->
@@ -59,7 +59,7 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr * Includecore.type_mismatch list
   | Constraint_failed of type_expr * type_expr
-  | Unconsistent_constraint of (type_expr * type_expr) list
+  | Inconsistent_constraint of (type_expr * type_expr) list
   | Type_clash of (type_expr * type_expr) list
   | Parameters_differ of Path.t * type_expr * type_expr
   | Null_arity_external
@@ -71,6 +71,7 @@ type error =
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
+  | Varying_anonymous
 
 exception Error of Location.t * error
 
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index e2b7e285..0feca199 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ type pattern =
   { pat_desc: pattern_desc;
     pat_loc: Location.t;
     pat_type: type_expr;
-    pat_env: Env.t }
+    mutable pat_env: Env.t }
 
 and pattern_desc =
     Tpat_any
@@ -110,8 +110,6 @@ and class_field =
     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
   | Cf_val of string * Ident.t * expression option * bool
   | Cf_meth of string * expression
-  | Cf_let of rec_flag * (pattern * expression) list *
-              (Ident.t * expression) list
   | Cf_init of expression
 
 (* Value expressions for the module language *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index eb64937c..0c5efa8e 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -23,7 +23,7 @@ type pattern =
   { pat_desc: pattern_desc;
     pat_loc: Location.t;
     pat_type: type_expr;
-    pat_env: Env.t }
+    mutable pat_env: Env.t }
 
 and pattern_desc =
     Tpat_any
@@ -112,8 +112,6 @@ and class_field =
   | Cf_val of string * Ident.t * expression option * bool
         (* None = virtual, true = override *)
   | Cf_meth of string * expression
-  | Cf_let of rec_flag * (pattern * expression) list *
-              (Ident.t * expression) list
   | Cf_init of expression
 
 (* Value expressions for the module language *)
@@ -163,6 +161,7 @@ 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
 
 (* Alpha conversion of patterns *)
 val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern
diff --git a/typing/typemod.ml b/typing/typemod.ml
index f1cc3f0a..0a3f24e2 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -39,6 +39,9 @@ type error =
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
   | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
 
 exception Error of Location.t * error
 
@@ -59,7 +62,7 @@ let extract_sig_open env loc mty =
 let type_open env loc lid =
   let (path, mty) = Typetexp.find_module env loc lid in
   let sg = extract_sig_open env loc mty in
-  Env.open_signature path sg env
+  Env.open_signature ~loc path sg env
 
 (* Record a module type *)
 let rm node =
@@ -119,7 +122,9 @@ let merge_constraint initial_env loc sg lid constr =
             type_manifest = None;
             type_variance =
               List.map (fun (c,n) -> (not n, not c, not c))
-              sdecl.ptype_variance }
+              sdecl.ptype_variance;
+            type_loc = Location.none;
+	    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 newdecl = Typedecl.transl_with_constraint
@@ -178,7 +183,8 @@ let merge_constraint initial_env loc sg lid constr =
                 List.map
                   (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit)
                   stl in
-              if params <> sdecl.ptype_params then raise Exit;
+              if List.map (fun x -> Some x) params <> sdecl.ptype_params
+	      then raise Exit;
               lid
           | _ -> raise Exit
           with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr))
@@ -375,8 +381,8 @@ and transl_signature env sg =
     | item :: srem ->
         match item.psig_desc with
         | Psig_value(name, sdesc) ->
-            let desc = Typedecl.transl_value_decl env sdesc in
-            let (id, newenv) = Env.enter_value name desc env in
+            let desc = Typedecl.transl_value_decl env item.psig_loc sdesc in
+            let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
             let rem = transl_sig newenv srem in
             if List.exists (Ident.equal id) (get_values rem) then rem
             else Tsig_value(id, desc) :: rem
@@ -388,7 +394,7 @@ and transl_signature env sg =
             let rem = transl_sig newenv srem in
             map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_exception(name, sarg) ->
-            let arg = Typedecl.transl_exception env sarg in
+            let arg = Typedecl.transl_exception env item.psig_loc sarg in
             let (id, newenv) = Env.enter_exception name arg env in
             let rem = transl_sig newenv srem in
             Tsig_exception(id, arg) :: rem
@@ -455,7 +461,7 @@ and transl_signature env sg =
                      Tsig_type(i', d', rs);
                      Tsig_type(i'', d'', rs)])
                  classes [rem])
-    in transl_sig env sg
+    in transl_sig (Env.in_signature env) sg
 
 and transl_modtype_info env sinfo =
   match sinfo with
@@ -642,6 +648,51 @@ let check_recmodule_inclusion env bindings =
     end
   in check_incl true (List.length bindings) env Subst.identity
 
+(* Helper for unpack *)
+
+let rec package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else let sg = extract_sig env loc mty in
+  let sg' =
+    List.map
+      (function
+        | Tsig_type (id, ({type_params=[]} as td), rs) when List.mem_assoc [Ident.name id] constrs ->
+            let ty = List.assoc [Ident.name id] constrs in
+            Tsig_type (id, {td with type_manifest = Some ty}, rs)
+        | Tsig_module (id, mty, rs) ->
+            let rec aux = function
+              | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest
+              | _ :: rest -> aux rest
+              | [] -> []
+            in
+            Tsig_module (id, package_constraints env loc mty (aux constrs), rs)
+        | item -> item
+      )
+      sg
+  in
+  Tmty_signature sg'
+
+let modtype_of_package env loc p nl tl =
+  try match Env.find_modtype p env with
+  | Tmodtype_manifest mty when nl <> [] ->
+      package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl)
+  | _ ->
+      if nl = [] then Tmty_ident p
+      else raise(Error(loc, Signature_expected))
+  with Not_found ->
+    raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p)))
+
+let wrap_constraint env arg mty =
+  let coercion =
+    try
+      Includemod.modtypes env arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_loc = arg.mod_loc }
+
 (* Type a module value expression *)
 
 let rec type_module sttn funct_body anchor env smod =
@@ -702,23 +753,35 @@ let rec type_module sttn funct_body anchor env smod =
   | Pmod_constraint(sarg, smty) ->
       let arg = type_module true funct_body anchor env sarg in
       let mty = transl_modtype env smty in
-      let coercion =
-        try
-          Includemod.modtypes env arg.mod_type mty
-        with Includemod.Error msg ->
-          raise(Error(sarg.pmod_loc, Not_included msg)) in
-      rm { mod_desc = Tmod_constraint(arg, mty, coercion);
-           mod_type = mty;
-           mod_env = env;
-           mod_loc = smod.pmod_loc }
+      rm {(wrap_constraint env arg mty) with mod_loc = smod.pmod_loc}
 
-  | Pmod_unpack (sexp, (p, l)) ->
+  | Pmod_unpack sexp ->
       if funct_body then
         raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
-      let l, mty = Typetexp.create_package_mty smod.pmod_loc env (p, l) in
-      let mty = transl_modtype env mty in
-      let exp = Typecore.type_expect env sexp
-          (Typecore.create_package_type smod.pmod_loc env (p, l)) in
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        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,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p nl tl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type))
+      in
       rm { mod_desc = Tmod_unpack(exp, mty);
            mod_type = mty;
            mod_env = env;
@@ -753,14 +816,16 @@ and type_structure funct_body anchor env sstr scope =
           Typecore.type_binding env rec_flag sdefs scope 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 =
           Tsig_value(id, Env.find_value (Pident id) newenv) in
         (Tstr_value(rec_flag, defs) :: str_rem,
          map_end make_sig_value bound_idents sig_rem,
          final_env)
-    | {pstr_desc = Pstr_primitive(name, sdesc)} :: srem ->
-        let desc = Typedecl.transl_value_decl env sdesc in
-        let (id, newenv) = Env.enter_value name desc env in
+    | {pstr_desc = Pstr_primitive(name, sdesc); pstr_loc = loc} :: srem ->
+        let desc = Typedecl.transl_value_decl env loc sdesc in
+        let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_primitive(id, desc) :: str_rem,
          Tsig_value(id, desc) :: sig_rem,
@@ -776,8 +841,8 @@ and type_structure funct_body anchor env sstr scope =
         (Tstr_type decls :: str_rem,
          map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
          final_env)
-    | {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
-        let arg = Typedecl.transl_exception env sarg in
+    | {pstr_desc = Pstr_exception(name, sarg); pstr_loc = loc} :: srem ->
+        let arg = Typedecl.transl_exception env loc sarg in
         let (id, newenv) = Env.enter_exception name arg env in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_exception(id, arg) :: str_rem,
@@ -964,12 +1029,56 @@ let type_module_type_of env smod =
     raise(Error(smod.pmod_loc, Non_generalizable_module mty));
   mty
 
+(* For Typecore *)
+
+let rec get_manifest_types = function
+    [] -> []
+  | Tsig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem ->
+      (Ident.name id, ty) :: get_manifest_types rem
+  | _ :: rem -> get_manifest_types rem
+
+let type_package env m p nl tl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  let lv = Ctype.get_current_level () in
+  Ctype.begin_def ();
+  Ident.set_current_time lv;
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  Ctype.init_def(Ident.current_time());
+  Typetexp.widen context;
+  let (mp, env) =
+    match modl.mod_desc with
+      Tmod_ident mp -> (mp, env)
+    | _ ->
+      let (id, new_env) = Env.enter_module "%M" modl.mod_type env in
+      (Pident id, new_env)
+  in
+  let rec mkpath mp = function
+    | Lident name -> Pdot(mp, name, nopos)
+    | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos)
+    | _ -> assert false
+  in
+  let tl' =
+    List.map (fun name -> Ctype.newconstr (mkpath mp name) []) nl in
+  (* go back to original level *)
+  Ctype.end_def ();
+  if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
+  let mty = modtype_of_package env modl.mod_loc p nl tl' in
+  List.iter2
+    (fun n ty ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty))))
+    nl tl';
+  (wrap_constraint env modl mty, tl')
+
 (* Fill in the forward declarations *)
 let () =
   Typecore.type_module := type_module;
   Typetexp.transl_modtype_longident := transl_modtype_longident;
   Typetexp.transl_modtype := transl_modtype;
   Typecore.type_open := type_open;
+  Typecore.type_package := type_package;
   type_module_type_of_fwd := type_module_type_of
 
 (* Typecheck an implementation file *)
@@ -978,7 +1087,6 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   Typecore.reset_delayed_checks ();
   let (str, sg, finalenv) = type_structure initial_env ast Location.none in
   let simple_sg = simplify_signature sg in
-  Typecore.force_delayed_checks ();
   if !Clflags.print_types then begin
     fprintf std_formatter "%a@." Printtyp.signature simple_sg;
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
@@ -993,6 +1101,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           raise(Error(Location.none, 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 ();
+      (* It is important to run these checks after the inclusion test above,
+         so that value declarations which are not used internally but exported
+         are not reported as being unused. *)
       (str, coercion)
     end else begin
       check_nongen_schemes finalenv str;
@@ -1000,6 +1112,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let coercion =
         Includemod.compunit sourcefile sg
                             "(inferred signature)" simple_sg in
+      Typecore.force_delayed_checks ();
+      (* See comment above. Here the target signature contains all
+         the value being exported. We can still capture unused
+         declarations like "let x = true;; let x = 1;;", because in this
+         case, the inferred signature contains only the last declaration. *)
       if not !Clflags.dont_write_files then
         Env.save_signature simple_sg modulename (outputprefix ^ ".cmi");
       (str, coercion)
@@ -1106,14 +1223,29 @@ let report_error ppf = function
            contains type variables that cannot be generalized@]" modtype mty
   | Implementation_is_required intf_name ->
       fprintf ppf
-        "@[The interface %s@ declares values, not just types.@ \
-           An implementation must be provided.@]" intf_name
+        "@[The interface %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
   | Interface_not_compiled intf_name ->
       fprintf ppf
-        "@[Could not find the .cmi file for interface@ %s.@]" intf_name
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
   | Not_allowed_in_functor_body ->
       fprintf ppf
         "This kind of expression is not allowed within the body of a functor."
   | With_need_typeconstr ->
       fprintf ppf
         "Only type constructors with identical parameters can be substituted."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      fprintf ppf
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      fprintf ppf
+        "The type %a in this module cannot be exported.@ " longident lid;
+      fprintf ppf
+        "Its type contains local dependencies:@ %a" type_expr ty
diff --git a/typing/typemod.mli b/typing/typemod.mli
index d508a429..a2c03aaa 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,6 +51,9 @@ type error =
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
   | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
 
 exception Error of Location.t * error
 
diff --git a/typing/types.ml b/typing/types.ml
index 5996719d..982dd76a 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -25,7 +25,7 @@ type type_expr =
     mutable id: int }
 
 and type_desc =
-    Tvar
+    Tvar of string option
   | Tarrow of label * type_expr * type_expr * commutable
   | Ttuple of type_expr list
   | Tconstr of Path.t * type_expr list * abbrev_memo ref
@@ -35,9 +35,9 @@ and type_desc =
   | Tlink of type_expr
   | Tsubst of type_expr         (* for copying *)
   | Tvariant of row_desc
-  | Tunivar
+  | Tunivar of string option
   | Tpoly of type_expr * type_expr list
-  | Tpackage of Path.t * string list * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
 
 and row_desc =
     { row_fields: (label * row_field) list;
@@ -87,7 +87,9 @@ module Vars = Meths
 
 type value_description =
   { val_type: type_expr;                (* Type of the value *)
-    val_kind: value_kind }
+    val_kind: value_kind;
+    val_loc: Location.t;
+ }
 
 and value_kind =
     Val_reg                             (* Regular value *)
@@ -106,17 +108,20 @@ and value_kind =
 
 type constructor_description =
   { cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
     cstr_args: type_expr list;          (* Type of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
     cstr_tag: constructor_tag;          (* Tag for heap blocks *)
     cstr_consts: int;                   (* Number of constant constructors *)
     cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
     cstr_private: private_flag }        (* Read-only constructor? *)
 
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
-  | Cstr_exception of Path.t            (* Exception constructor *)
+  | Cstr_exception of Path.t * Location.t (* Exception constructor *)
 
 (* Record label descriptions *)
 
@@ -142,16 +147,20 @@ 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: (bool * bool * bool) list;
+    (* covariant, contravariant, weakly contravariant *)
+    type_newtype_level: (int * int) option;
+    type_loc: Location.t }
 
 and type_kind =
     Type_abstract
-  | Type_variant of (string * type_expr list) list
   | Type_record of
       (string * mutable_flag * type_expr) list * record_representation
+  | Type_variant of (string * type_expr list * type_expr option) list 
 
-type exception_declaration = type_expr list
+type exception_declaration =
+    { exn_args: type_expr list;
+      exn_loc: Location.t }
 
 (* Type expressions for the class language *)
 
diff --git a/typing/types.mli b/typing/types.mli
index a4c64084..cf897bd7 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ type type_expr =
     mutable id: int }
 
 and type_desc =
-    Tvar
+    Tvar of string option
   | Tarrow of label * type_expr * type_expr * commutable
   | Ttuple of type_expr list
   | Tconstr of Path.t * type_expr list * abbrev_memo ref
@@ -34,9 +34,9 @@ and type_desc =
   | Tlink of type_expr
   | Tsubst of type_expr         (* for copying *)
   | Tvariant of row_desc
-  | Tunivar
+  | Tunivar of string option
   | Tpoly of type_expr * type_expr list
-  | Tpackage of Path.t * string list * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
 
 and row_desc =
     { row_fields: (label * row_field) list;
@@ -85,7 +85,9 @@ module Vars  : Map.S with type key = string
 
 type value_description =
   { val_type: type_expr;                (* Type of the value *)
-    val_kind: value_kind }
+    val_kind: value_kind;
+    val_loc: Location.t;
+   }
 
 and value_kind =
     Val_reg                             (* Regular value *)
@@ -103,17 +105,20 @@ and value_kind =
 
 type constructor_description =
   { cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
     cstr_args: type_expr list;          (* Type of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
     cstr_tag: constructor_tag;          (* Tag for heap blocks *)
-    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_consts: int;                   (* Number of constant constructors *) 
     cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
     cstr_private: private_flag }        (* Read-only constructor? *)
 
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
-  | Cstr_exception of Path.t            (* Exception constructor *)
+  | Cstr_exception of Path.t * Location.t (* Exception constructor *)
 
 (* Record label descriptions *)
 
@@ -139,16 +144,21 @@ 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: (bool * bool * bool) list;
+    (* covariant, contravariant, weakly contravariant *)
+    type_newtype_level: (int * int) option;
+    (* definition level * expansion level *)
+    type_loc: Location.t }
 
 and type_kind =
     Type_abstract
-  | Type_variant of (string * type_expr list) list
   | Type_record of
       (string * mutable_flag * type_expr) list * record_representation
+  | Type_variant of (string * type_expr list * type_expr option) list
 
-type exception_declaration = type_expr list
+type exception_declaration =
+    { exn_args: type_expr list;
+      exn_loc: Location.t }
 
 (* Type expressions for the class language *)
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 838719b7..131b12a7 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -38,7 +38,7 @@ type error =
   | Variant_tags of string * string
   | Invalid_variable_name of string
   | Cannot_quantify of string * type_expr
-  | Multiple_constraints_on_type of string
+  | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
@@ -53,12 +53,18 @@ exception Error of Location.t * error
 
 type variable_context = int * (string, type_expr) Tbl.t
 
+(* Local definitions *)
+
+let instance_list = Ctype.instance_list Env.empty
+
 (* Narrowing unbound identifier errors. *)
 
 let rec narrow_unbound_lid_error 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
+    with Not_found ->
+      narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid);
+      assert false
   in
   begin match lid with
   | Longident.Lident _ -> ()
@@ -73,28 +79,30 @@ let rec narrow_unbound_lid_error env loc lid make_error =
 let find_component lookup make_error env loc lid =
   try
     match lid with
-    | Longident.Ldot (Longident.Lident "*predef*", s) -> lookup (Longident.Lident s) Env.initial
+    | Longident.Ldot (Longident.Lident "*predef*", s) ->
+        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
 
-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_label = find_component Env.lookup_label (fun lid -> Unbound_label lid)
-
-let find_class = find_component Env.lookup_class (fun lid -> Unbound_class lid)
-
-let find_value = find_component Env.lookup_value (fun lid -> Unbound_value lid)
-
-let find_module = find_component Env.lookup_module (fun lid -> Unbound_module lid)
-
-let find_modtype = find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
-
-let find_cltype = find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
+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_label =
+  find_component Env.lookup_label (fun lid -> Unbound_label lid)
+let find_class =
+  find_component Env.lookup_class (fun lid -> Unbound_class lid)
+let find_value =
+  find_component Env.lookup_value (fun lid -> Unbound_value lid)
+let find_module =
+  find_component Env.lookup_module (fun lid -> Unbound_module lid)
+let find_modtype =
+  find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
+let find_cltype =
+  find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
 
 (* Support for first-class modules. *)
 
@@ -119,7 +127,8 @@ let create_package_mty fake loc env (p, l) =
                ptype_manifest = if fake then None else Some t;
                ptype_variance = [];
                ptype_loc = loc} in
-      {pmty_desc=Pmty_with (mty, [ Longident.Lident s, Pwith_type d ]); pmty_loc=loc}
+      {pmty_desc=Pmty_with (mty, [ s, Pwith_type d ]);
+       pmty_loc=loc}
     )
     {pmty_desc=Pmty_ident p; pmty_loc=loc}
     l
@@ -142,6 +151,18 @@ let widen (gl, tv) =
   restore_global_level gl;
   type_variables := tv
 
+let strict_lowercase c = (c = '_' || c >= 'a' && c <= 'z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_lowercase name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
 let enter_type_variable strict loc name =
   try
     if name <> "" && name.[0] = '_' then
@@ -150,7 +171,7 @@ let enter_type_variable strict loc name =
     if strict then raise Already_bound;
     v
   with Not_found ->
-    let v = new_global_var() in
+    let v = new_global_var ~name () in
     type_variables := Tbl.add name v !type_variables;
     v
 
@@ -165,8 +186,8 @@ let wrap_method ty =
     Tpoly _ -> ty
   | _ -> Ctype.newty (Tpoly (ty, []))
 
-let new_pre_univar () =
-  let v = newvar () in pre_univars := v :: !pre_univars; v
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
 
 let rec swap_list = function
     x :: y :: l -> y :: x :: swap_list l
@@ -185,12 +206,13 @@ let rec transl_type env policy styp =
       if name <> "" && name.[0] = '_' then
         raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
       begin try
-        instance (List.assoc name !univars)
+        instance env (List.assoc name !univars)
       with Not_found -> try
-        instance (fst(Tbl.find name !used_variables))
+        instance env (fst(Tbl.find name !used_variables))
       with Not_found ->
         let v =
-          if policy = Univars then new_pre_univar () else newvar () in
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
         used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
         v
       end
@@ -206,7 +228,7 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let params = Ctype.instance_list decl.type_params in
+      let params = instance_list decl.type_params in
       let unify_param =
         match decl.type_manifest with
           None -> unify_var
@@ -260,7 +282,7 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                        List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let params = Ctype.instance_list decl.type_params in
+      let params = instance_list decl.type_params in
       List.iter2
         (fun (sty, ty) ty' ->
            try unify_var env ty' ty with Unify trace ->
@@ -295,7 +317,8 @@ let rec transl_type env policy styp =
                       row_fixed = false; row_more = newvar () } in
           let static = Btype.static_row row in
           let row =
-            if static || policy <> Univars then row
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
             else { row with row_more = new_pre_univar () }
           in
           newty (Tvariant row)
@@ -312,7 +335,7 @@ let rec transl_type env policy styp =
           let t =
             try List.assoc alias !univars
             with Not_found ->
-              instance (fst(Tbl.find alias !used_variables))
+              instance env (fst(Tbl.find alias !used_variables))
           in
           let ty = transl_type env policy st in
           begin try unify_var env t ty with Unify trace ->
@@ -333,7 +356,14 @@ let rec transl_type env policy styp =
             end_def ();
             generalize_structure t;
           end;
-          instance t
+          let t = instance env t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
+          | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
+          | _ -> ()
+          end;
+          t
       end
   | Ptyp_variant(fields, closed, present) ->
       let name = ref None in
@@ -388,7 +418,7 @@ let rec transl_type env policy styp =
               {desc=Tvariant row}, _ when Btype.static_row row ->
                 let row = Btype.row_repr row in
                 row.row_fields
-            | {desc=Tvar}, Some(p, _) ->
+            | {desc=Tvar _}, Some(p, _) ->
                 raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
             | _ ->
                 raise(Error(sty.ptyp_loc, Not_a_variant ty))
@@ -425,13 +455,14 @@ let rec transl_type env policy styp =
           row_fixed = false; row_name = !name } in
       let static = Btype.static_row row in
       let row =
-        if static || policy <> Univars then row
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
         else { row with row_more = new_pre_univar () }
       in
       newty (Tvariant row)
   | Ptyp_poly(vars, st) ->
       begin_def();
-      let new_univars = List.map (fun name -> name, newvar()) vars in
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
       let old_univars = !univars in
       univars := new_univars @ !univars;
       let ty = transl_type env policy st in
@@ -443,10 +474,12 @@ let rec transl_type env policy styp =
           (fun tyl (name, ty1) ->
             let v = Btype.proxy ty1 in
             if deep_occur v ty then begin
-              if v.level <> Btype.generic_level || v.desc <> Tvar then
-                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
-              v.desc <- Tunivar;
-              v :: tyl
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  v.desc <- Tunivar name;
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
             end else tyl)
           [] new_univars
       in
@@ -483,7 +516,7 @@ let rec make_fixed_univars ty =
     match ty.desc with
     | Tvariant row ->
         let row = Btype.row_repr row in
-        if (Btype.row_more row).desc = Tunivar then
+        if Btype.is_Tunivar (Btype.row_more row) then
           ty.desc <- Tvariant
               {row with row_fixed=true;
                row_fields = List.map
@@ -512,7 +545,7 @@ let globalize_used_variables env fixed =
       then try
         r := (loc, v,  Tbl.find name !type_variables) :: !r
       with Not_found ->
-        if fixed && (repr ty).desc = Tvar then
+        if fixed && Btype.is_Tvar (repr ty) then
           raise(Error(loc, Unbound_type_variable ("'"^name)));
         let v2 = new_global_var () in
         r := (loc, v, v2) :: !r;
@@ -552,12 +585,14 @@ let transl_simple_type_univars env styp =
     List.fold_left
       (fun acc v ->
         let v = repr v in
-        if v.level <> Btype.generic_level || v.desc <> Tvar then acc
-        else (v.desc <- Tunivar ; v :: acc))
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            v.desc <- Tunivar name; v :: acc
+        | _ -> acc)
       [] !pre_univars
   in
   make_fixed_univars typ;
-  instance (Btype.newgenty (Tpoly (typ, univs)))
+  instance env (Btype.newgenty (Tpoly (typ, univs)))
 
 let transl_simple_type_delayed env styp =
   univars := []; used_variables := Tbl.empty;
@@ -629,17 +664,19 @@ let report_error ppf = function
         Printtyp.type_expr ty
   | Variant_tags (lab1, lab2) ->
       fprintf ppf
-        "Variant tags `%s@ and `%s have the same hash value.@ Change one of them."
-        lab1 lab2
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
   | Invalid_variable_name name ->
       fprintf ppf "The type variable name %s is not allowed in programs" name
   | Cannot_quantify (name, v) ->
-      fprintf ppf "This type scheme cannot quantify '%s :@ %s." name
-        (if v.desc = Tvar then "it escapes this scope" else
-         if v.desc = Tunivar then "it is aliased to another variable"
+      fprintf ppf
+        "@[The universal type variable '%s cannot be generalized:@ %s.@]"
+        name
+        (if Btype.is_Tvar v then "it escapes its scope" else
+         if Btype.is_Tunivar v then "it is already bound to another variable"
          else "it is not a variable")
   | Multiple_constraints_on_type s ->
-      fprintf ppf "Multiple constraints for type %s" s
+      fprintf ppf "Multiple constraints for type %a" longident s
   | Repeated_method_label s ->
       fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
         s "Multiple occurences are not allowed."
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index ec9042ce..79082d5f 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -53,7 +53,7 @@ type error =
   | Variant_tags of string * string
   | Invalid_variable_name of string
   | Cannot_quantify of string * Types.type_expr
-  | Multiple_constraints_on_type of string
+  | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
@@ -71,7 +71,7 @@ val report_error: formatter -> error -> unit
 (* Support for first-class modules. *)
 val transl_modtype_longident: (Location.t -> Env.t -> Longident.t -> Path.t) ref  (* from Typemod *)
 val transl_modtype: (Env.t -> Parsetree.module_type -> Types.module_type) ref (* from Typemod *)
-val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (string * Parsetree.core_type) list * Parsetree.module_type
+val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (Longident.t * Parsetree.core_type) list * Parsetree.module_type
 
 val find_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
 val find_constructor: Env.t -> Location.t -> Longident.t -> Types.constructor_description
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
deleted file mode 100644
index c90b6e80..00000000
--- a/typing/unused_var.ml
+++ /dev/null
@@ -1,267 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 2004 Institut National de 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 Parsetree
-
-let silent v = String.length v > 0 && v.[0] = '_';;
-
-let add_vars tbl (vll1, vll2) =
-  let add_var (v, _loc, used) = Hashtbl.add tbl v used in
-  List.iter add_var vll1;
-  List.iter add_var vll2;
-;;
-
-let rm_vars tbl (vll1, vll2) =
-  let rm_var (v, _, _) = Hashtbl.remove tbl v in
-  List.iter rm_var vll1;
-  List.iter rm_var vll2;
-;;
-
-let w_suspicious x = Warnings.Unused_var x;;
-let w_strict x = Warnings.Unused_var_strict x;;
-
-let check_rm_vars ppf tbl (vlul_pat, vlul_as) =
-  let check_rm_var kind (v, loc, used) =
-    if not !used && not (silent v)
-    then Location.print_warning loc ppf (kind v);
-    Hashtbl.remove tbl v;
-  in
-  List.iter (check_rm_var w_strict) vlul_pat;
-  List.iter (check_rm_var w_suspicious) vlul_as;
-;;
-
-let check_rm_let ppf tbl vlulpl =
-  let check_rm_one flag (v, loc, used) =
-    Hashtbl.remove tbl v;
-    flag && (silent v || not !used)
-  in
-  let warn_var w_kind (v, loc, used) =
-    if not (silent v) && not !used
-    then Location.print_warning loc ppf (w_kind v)
-  in
-  let check_rm_pat (def, def_as) =
-    let def_unused = List.fold_left check_rm_one true def in
-    let all_unused = List.fold_left check_rm_one def_unused def_as in
-    List.iter (warn_var (if all_unused then w_suspicious else w_strict)) def;
-    List.iter (warn_var w_suspicious) def_as;
-  in
-  List.iter check_rm_pat vlulpl;
-;;
-
-let rec get_vars ((vacc, asacc) as acc) p =
-  match p.ppat_desc with
-  | Ppat_any -> acc
-  | Ppat_var v -> ((v, p.ppat_loc, ref false) :: vacc, asacc)
-  | Ppat_alias (pp, v) ->
-      get_vars (vacc, ((v, p.ppat_loc, ref false) :: asacc)) pp
-  | Ppat_constant _ -> acc
-  | Ppat_tuple pl -> List.fold_left get_vars acc pl
-  | Ppat_construct (_, po, _) -> get_vars_option acc po
-  | Ppat_variant (_, po) -> get_vars_option acc po
-  | Ppat_record (ipl, cls) ->
-      List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
-  | Ppat_array pl -> List.fold_left get_vars acc pl
-  | Ppat_or (p1, _p2) -> get_vars acc p1
-  | Ppat_lazy p -> get_vars acc p
-  | Ppat_constraint (pp, _) -> get_vars acc pp
-  | Ppat_type _ -> acc
-
-and get_vars_option acc po =
-  match po with
-  | Some p -> get_vars acc p
-  | None -> acc
-;;
-
-let get_pel_vars pel =
-  List.map (fun (p, _) -> get_vars ([], []) p) pel
-;;
-
-let rec structure ppf tbl l =
-  List.iter (structure_item ppf tbl) l
-
-and structure_item ppf tbl s =
-  match s.pstr_desc with
-  | Pstr_eval e -> expression ppf tbl e;
-  | Pstr_value (recflag, pel) -> let_pel ppf tbl recflag pel None;
-  | Pstr_primitive _ -> ()
-  | Pstr_type _ -> ()
-  | Pstr_exception _ -> ()
-  | Pstr_exn_rebind _ -> ()
-  | Pstr_module (_, me) -> module_expr ppf tbl me;
-  | Pstr_recmodule stml ->
-      List.iter (fun (_, _, me) -> module_expr ppf tbl me) stml;
-  | Pstr_modtype _ -> ()
-  | Pstr_open _ -> ()
-  | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl;
-  | Pstr_class_type _ -> ()
-  | Pstr_include me -> module_expr ppf tbl me;
-
-and expression ppf tbl e =
-  match e.pexp_desc with
-  | Pexp_ident (Longident.Lident id) ->
-      begin try (Hashtbl.find tbl id) := true;
-      with Not_found -> ()
-      end;
-  | Pexp_ident _ -> ()
-  | Pexp_constant _ -> ()
-  | Pexp_let (recflag, pel, e) ->
-      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> expression ppf tbl e));
-  | Pexp_function (_, eo, pel) ->
-      expression_option ppf tbl eo;
-      match_pel ppf tbl pel;
-  | Pexp_apply (e, lel) ->
-      expression ppf tbl e;
-      List.iter (fun (_, e) -> expression ppf tbl e) lel;
-  | Pexp_match (e, pel) ->
-      expression ppf tbl e;
-      match_pel ppf tbl pel;
-  | Pexp_try (e, pel) ->
-      expression ppf tbl e;
-      match_pel ppf tbl pel;
-  | Pexp_tuple el -> List.iter (expression ppf tbl) el;
-  | Pexp_construct (_, eo, _) -> expression_option ppf tbl eo;
-  | Pexp_variant (_, eo) -> expression_option ppf tbl eo;
-  | Pexp_record (iel, eo) ->
-      List.iter (fun (_, e) -> expression ppf tbl e) iel;
-      expression_option ppf tbl eo;
-  | Pexp_field (e, _) -> expression ppf tbl e;
-  | Pexp_setfield (e1, _, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_array el -> List.iter (expression ppf tbl) el;
-  | Pexp_ifthenelse (e1, e2, eo) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-      expression_option ppf tbl eo;
-  | Pexp_sequence (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_while (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_for (id, e1, e2, _, e3) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-      let defined = ([ (id, e.pexp_loc, ref true) ], []) in
-      add_vars tbl defined;
-      expression ppf tbl e3;
-      check_rm_vars ppf tbl defined;
-  | Pexp_constraint (e, _, _) -> expression ppf tbl e;
-  | Pexp_when (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_send (e, _) -> expression ppf tbl e;
-  | Pexp_new _ -> ()
-  | Pexp_setinstvar (_, e) -> expression ppf tbl e;
-  | Pexp_override sel -> List.iter (fun (_, e) -> expression ppf tbl e) sel;
-  | Pexp_letmodule (_, me, e) ->
-      module_expr ppf tbl me;
-      expression ppf tbl e;
-  | Pexp_assert e -> expression ppf tbl e;
-  | Pexp_assertfalse -> ()
-  | Pexp_lazy e -> expression ppf tbl e;
-  | Pexp_poly (e, _) -> expression ppf tbl e;
-  | Pexp_object cs -> class_structure ppf tbl cs;
-  | Pexp_newtype (_, e) -> expression ppf tbl e
-  | Pexp_pack (me, _) -> module_expr ppf tbl me
-  | Pexp_open (_, e) -> expression ppf tbl e
-
-and expression_option ppf tbl eo =
-  match eo with
-  | Some e -> expression ppf tbl e;
-  | None -> ()
-
-and let_pel ppf tbl recflag pel body =
-  match recflag with
-  | Asttypes.Recursive ->
-      let defined = get_pel_vars pel in
-      List.iter (add_vars tbl) defined;
-      List.iter (fun (_, e) -> expression ppf tbl e) pel;
-      begin match body with
-      | None ->
-          List.iter (rm_vars tbl) defined;
-      | Some f ->
-          f ppf tbl;
-          check_rm_let ppf tbl defined;
-      end;
-  | _ ->
-      List.iter (fun (_, e) -> expression ppf tbl e) pel;
-      begin match body with
-      | None -> ()
-      | Some f ->
-          let defined = get_pel_vars pel in
-          List.iter (add_vars tbl) defined;
-          f ppf tbl;
-          check_rm_let ppf tbl defined;
-      end;
-
-and match_pel ppf tbl pel =
-  List.iter (match_pe ppf tbl) pel
-
-and match_pe ppf tbl (p, e) =
- let defined = get_vars ([], []) p in
-  add_vars tbl defined;
-  expression ppf tbl e;
-  check_rm_vars ppf tbl defined;
-
-and module_expr ppf tbl me =
-  match me.pmod_desc with
-  | Pmod_ident _ -> ()
-  | Pmod_structure s -> structure ppf tbl s
-  | Pmod_functor (_, _, me) -> module_expr ppf tbl me
-  | Pmod_apply (me1, me2) ->
-      module_expr ppf tbl me1;
-      module_expr ppf tbl me2;
-  | Pmod_constraint (me, _) -> module_expr ppf tbl me
-  | Pmod_unpack (e, _) -> expression ppf tbl e
-
-and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr
-
-and class_expr ppf tbl ce =
-  match ce.pcl_desc with
-  | Pcl_constr _ -> ()
-  | Pcl_structure cs -> class_structure ppf tbl cs;
-  | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce;
-  | Pcl_apply (ce, lel) ->
-      class_expr ppf tbl ce;
-      List.iter (fun (_, e) -> expression ppf tbl e) lel;
-  | Pcl_let (recflag, pel, ce) ->
-      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
-  | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
-
-and class_structure ppf tbl (p, cfl) =
-  let defined = get_vars ([], []) p in
-  add_vars tbl defined;
-  List.iter (class_field ppf tbl) cfl;
-  check_rm_vars ppf tbl defined;
-
-and class_field ppf tbl cf =
-  match cf with
-  | Pcf_inher (_, ce, _) -> class_expr ppf tbl ce;
-  | Pcf_val (_, _, _, e, _) -> expression ppf tbl e;
-  | Pcf_virt _ | Pcf_valvirt _ -> ()
-  | Pcf_meth (_, _, _, e, _) -> expression ppf tbl e;
-  | Pcf_cstr _ -> ()
-  | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
-  | Pcf_init e -> expression ppf tbl e;
-;;
-
-let warn ppf ast =
-  if Warnings.is_active (w_suspicious "") || Warnings.is_active (w_strict "")
-  then begin
-    let tbl = Hashtbl.create 97 in
-    structure ppf tbl ast;
-  end;
-  ast
-;;
diff --git a/typing/unused_var.mli b/typing/unused_var.mli
deleted file mode 100644
index be36fcca..00000000
--- a/typing/unused_var.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 2004 Institut National de 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$ *)
-
-val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;;
-(* Warn on unused variables; return the second argument. *)
diff --git a/utils/.cvsignore b/utils/.cvsignore
deleted file mode 100644
index 25b6d3bc..00000000
--- a/utils/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-config.ml
diff --git a/utils/.ignore b/utils/.ignore
new file mode 100644
index 00000000..25b6d3bc
--- /dev/null
+++ b/utils/.ignore
@@ -0,0 +1 @@
+config.ml
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index 94a29217..66525e5b 100644
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -73,9 +73,10 @@ let create_archive archive file_list =
       command(Printf.sprintf "link /lib /nologo /out:%s %s"
                              quoted_archive (quote_files file_list))
   | _ ->
+      assert(String.length Config.ar > 0);
       let r1 =
-        command(Printf.sprintf "ar rc %s %s"
-                quoted_archive (quote_files file_list)) in
+        command(Printf.sprintf "%s rc %s %s"
+                Config.ar quoted_archive (quote_files file_list)) in
       if r1 <> 0 || String.length Config.ranlib = 0
       then r1
       else command(Config.ranlib ^ " " ^ quoted_archive)
diff --git a/utils/ccomp.mli b/utils/ccomp.mli
index 72ae7131..687c701f 100644
--- a/utils/ccomp.mli
+++ b/utils/ccomp.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 1074d362..51c80ed0 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -39,6 +39,7 @@ and use_vmthreads = ref false           (* -vmthread *)
 and noassert = ref false                (* -noassert *)
 and verbose = ref false                 (* -verbose *)
 and noprompt = ref false                (* -noprompt *)
+and nopromptcont = ref false            (* -nopromptcont *)
 and init_file = ref (None : string option)   (* -init *)
 and use_prims = ref ""                  (* -use-prims ... *)
 and use_runtime = ref ""                (* -use-runtime ... *)
@@ -46,16 +47,18 @@ and principal = ref false               (* -principal *)
 and recursive_types = ref false         (* -rectypes *)
 and strict_sequence = ref false         (* -strict-sequence *)
 and applicative_functors = ref true     (* -no-app-funct *)
-and make_runtime = ref false            (* -make_runtime *)
+and make_runtime = ref false            (* -make-runtime *)
 and gprofile = ref false                (* -p *)
 and c_compiler = ref (None: string option) (* -cc *)
 and no_auto_link = ref false            (* -noautolink *)
 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_parsetree = ref false          (* -dparsetree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
+and dump_clambda = ref false            (* -dclambda *)
 and dump_instr = ref false              (* -dinstr *)
 
 let keep_asm_file = ref false           (* -S *)
@@ -92,3 +95,5 @@ let std_include_dir () =
 
 let shared = ref false (* -shared *)
 let dlcode = ref true (* not -nodynlink *)
+
+let runtime_variant = ref "";;     (* -runtime-variant *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index d5357ef3..4cff375a 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -36,6 +36,7 @@ val use_vmthreads : bool ref
 val noassert : bool ref
 val verbose : bool ref
 val noprompt : bool ref
+val nopromptcont : bool ref
 val init_file : string option ref
 val use_prims : string ref
 val use_runtime : string ref
@@ -50,9 +51,11 @@ val no_auto_link : bool ref
 val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
+val error_size : int ref
 val dump_parsetree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref
+val dump_clambda : bool ref
 val dump_instr : bool ref
 val keep_asm_file : bool ref
 val optimize_for_speed : bool ref
@@ -76,3 +79,4 @@ val std_include_flag : string -> string
 val std_include_dir : unit -> string list
 val shared : bool ref
 val dlcode : bool ref
+val runtime_variant : string ref
diff --git a/utils/config.mlbuild b/utils/config.mlbuild
index 68a7c858..ca6e6d47 100644
--- a/utils/config.mlbuild
+++ b/utils/config.mlbuild
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -55,19 +55,20 @@ let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts
 let native_c_libraries = C.nativecclibs
 let native_pack_linker = C.packld
 let ranlib = C.ranlibcmd
+let ar = C.arcmd
 let cc_profile = C.cc_profile
 let mkdll = C.mkdll
 let mkexe = C.mkexe
 let mkmaindll = C.mkmaindll
 
 let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I012"
+and cmi_magic_number = "Caml1999I013"
 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 = "Caml1999M013"
-and ast_intf_magic_number = "Caml1999N012"
+and ast_impl_magic_number = "Caml1999M014"
+and ast_intf_magic_number = "Caml1999N013"
 and cmxs_magic_number = "Caml2007D001"
 
 let load_path = ref ([] : string list)
@@ -88,6 +89,7 @@ let model = C.model
 let system = C.system
 
 let asm = C.asm
+let asm_cfi_supported = C.asm_cfi_supported
 
 let ext_obj = C.ext_obj
 let ext_asm = C.ext_asm
@@ -121,6 +123,7 @@ let print_config oc =
   p "model" model;
   p "system" system;
   p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;
diff --git a/utils/config.mli b/utils/config.mli
index da39808b..822df4b0 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,10 +22,9 @@ val standard_library: string
 val standard_runtime: string
         (* The full path to the standard bytecode interpreter ocamlrun *)
 val ccomp_type: string
-        (* The "kind" of the C compiler: one of
+        (* The "kind" of the C compiler, assembler and linker used: one of
                "cc" (for Unix-style C compilers)
-               "msvc" (Microsoft Visual C++)
-               "mrc" (Macintosh MPW) *)
+               "msvc" (for Microsoft Visual C++ and MASM) *)
 val bytecomp_c_compiler: string
         (* The C compiler to use for compiling C files
            with the bytecode compiler *)
@@ -47,6 +46,8 @@ val mkmaindll: string
         (* The linker command line to build main programs as dlls. *)
 val ranlib: string
         (* Command to randomize a library, or "" if not needed *)
+val ar: string
+        (* Name of the ar command, or "" if not needed  (MSVC) *)
 val cc_profile : string
         (* The command line option to the C compiler to enable profiling. *)
 
@@ -98,6 +99,9 @@ val asm: string
         (* The assembler (and flags) to use for assembling
            ocamlopt-generated code. *)
 
+val asm_cfi_supported: bool
+        (* Whether assembler understands CFI directives *)
+
 val ext_obj: string
         (* Extension for object files, e.g. [.o] under Unix. *)
 val ext_asm: string
diff --git a/utils/config.mlp b/utils/config.mlp
index 4cabf90b..9b3edb98 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -44,19 +44,20 @@ let native_c_compiler = "%%NATIVECC%%"
 let native_c_libraries = "%%NATIVECCLIBS%%"
 let native_pack_linker = "%%PACKLD%%"
 let ranlib = "%%RANLIBCMD%%"
+let ar = "%%ARCMD%%"
 let cc_profile = "%%CC_PROFILE%%"
 let mkdll = "%%MKDLL%%"
 let mkexe = "%%MKEXE%%"
 let mkmaindll = "%%MKMAINDLL%%"
 
 let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I012"
+and cmi_magic_number = "Caml1999I013"
 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 = "Caml1999M013"
-and ast_intf_magic_number = "Caml1999N012"
+and ast_impl_magic_number = "Caml1999M014"
+and ast_intf_magic_number = "Caml1999N013"
 and cmxs_magic_number = "Caml2007D001"
 
 let load_path = ref ([] : string list)
@@ -77,6 +78,7 @@ let model = "%%MODEL%%"
 let system = "%%SYSTEM%%"
 
 let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -110,6 +112,7 @@ let print_config oc =
   p "model" model;
   p "system" system;
   p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index d01d7c87..f724e4f8 100644
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/consistbl.mli b/utils/consistbl.mli
index edaac12f..a877733b 100644
--- a/utils/consistbl.mli
+++ b/utils/consistbl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/misc.ml b/utils/misc.ml
index 68ca8e3d..1f5bb98b 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -21,12 +21,10 @@ let fatal_error msg =
 
 (* Exceptions *)
 
-let try_finally f1 f2 =
-  try
-    let result = f1 () in
-    f2 ();
-    result
-  with x -> f2 (); raise x
+let try_finally work cleanup =
+  let result = (try work () with e -> cleanup (); raise e) in
+  cleanup ();
+  result
 ;;
 
 (* List functions *)
@@ -143,6 +141,14 @@ let copy_file_chunk ic oc len =
     end
   in copy len
 
+(* Reading from a channel *)
+
+let input_bytes ic n =
+  let result = String.create n in
+  really_input ic result 0 n;
+  result
+;;
+
 (* Integer operations *)
 
 let rec log2 n =
@@ -195,3 +201,7 @@ let rev_split_words s =
       | _ -> split2 res i (j+1)
     end
   in split1 [] 0
+
+let get_ref r =
+  let v = !r in
+  r := []; v
diff --git a/utils/misc.mli b/utils/misc.mli
index 87f74e25..6ccb1b66 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -66,6 +66,11 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit
            them to [oc]. It raises [End_of_file] when encountering
            EOF on [ic]. *)
 
+val input_bytes : in_channel -> int -> string;;
+        (* [input_bytes ic n] reads [n] bytes from [ic] and returns them
+           in a new string.  It raises [End_of_file] if EOF is encountered
+           before all the bytes are read. *)
+
 val log2: int -> int
         (* [log2 n] returns [s] such that [n = 1 lsl s]
            if [n] is a power of 2*)
@@ -102,3 +107,7 @@ val search_substring: string -> string -> int -> int
 val rev_split_words: string -> string list
         (* [rev_split_words s] splits [s] in blank-separated words, and return
            the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)
diff --git a/utils/tbl.ml b/utils/tbl.ml
index b0651693..63c133a2 100644
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/tbl.mli b/utils/tbl.mli
index 44a021a7..626fd4c1 100644
--- a/utils/tbl.mli
+++ b/utils/tbl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/terminfo.ml b/utils/terminfo.ml
index cc179910..4619ac61 100644
--- a/utils/terminfo.ml
+++ b/utils/terminfo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/terminfo.mli b/utils/terminfo.mli
index ef26b61a..5fa3aa14 100644
--- a/utils/terminfo.mli
+++ b/utils/terminfo.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 72885523..e633c562 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -50,6 +50,14 @@ type t =
   | 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 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -89,9 +97,17 @@ let number = function
   | Wildcard_arg_to_constant_constr -> 28
   | Eol_in_string -> 29
   | Duplicate_definitions _ -> 30
+  | Multiple_definition _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_exception _ -> 38
 ;;
 
-let last_warning_number = 30;;
+let last_warning_number = 38;;
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -107,7 +123,7 @@ let letter = function
   | 'h' -> []
   | 'i' -> []
   | 'j' -> []
-  | 'k' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38]
   | 'l' -> [6]
   | 'm' -> [7]
   | 'n' -> []
@@ -186,7 +202,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";;
+let defaults_w = "+a-4-6-7-9-27-29-32..38";;
 let defaults_warn_error = "-a";;
 
 let () = parse_options false defaults_w;;
@@ -219,7 +235,7 @@ let message = function
        Here is an example of a value that is not matched:\n" ^ s
   | Non_closed_record_pattern s ->
       "the following labels are not bound in this record pattern:\n" ^ s ^
-      "\nEither bind these labels explicitly or add `; _' to the pattern."
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
   | Statement_type ->
       "this expression should have type unit."
   | Unused_match -> "this match case is unused."
@@ -246,8 +262,8 @@ let message = function
       "this statement never returns (or has an unsound type.)"
   | Camlp4 s -> s
   | Useless_record_with ->
-      "this record is defined by a `with' expression,\n\
-       but no fields are borrowed from the original."
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
   | Bad_module_name (modname) ->
       "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
   | All_clauses_guarded ->
@@ -260,6 +276,30 @@ let message = function
   | Duplicate_definitions (kind, cname, tc1, tc2) ->
       Printf.sprintf "the %s %s is defined in both types %s and %s."
         kind cname tc1 tc2
+  | Multiple_definition(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, true, _) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, false, true) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_exception (s, false) ->
+      "unused exception constructor " ^ s ^ "."
+  | Unused_exception (s, true) ->
+      "exception constructor " ^ s ^
+      " is never raised or used to build values.\n\
+        (However, this constructor appears in patterns.)"
 ;;
 
 let nerrors = ref 0;;
@@ -293,7 +333,6 @@ let check_fatal () =
   end;
 ;;
 
-
 let descriptions =
   [
     1, "Suspicious-looking start-of-comment mark.";
@@ -305,14 +344,14 @@ let descriptions =
     5, "Partially applied function: expression whose result has function\n\
    \    type and is ignored.";
     6, "Label omitted in function application.";
-    7, "Some methods are overridden in the class where they are defined.";
+    7, "Method overridden.";
     8, "Partial match: missing cases in pattern-matching.";
     9, "Missing fields in a record pattern.";
    10, "Expression on the left-hand side of a sequence that doesn't have type\n\
    \    \"unit\" (and that is not a function, see warning number 5).";
    11, "Redundant case in a pattern matching (unused match case).";
    12, "Redundant sub-pattern in a pattern-matching.";
-   13, "Override of an instance variable.";
+   13, "Instance variable overridden.";
    14, "Illegal backslash escape in a string constant.";
    15, "Private method made public implicitly.";
    16, "Unerasable optional argument.";
@@ -323,11 +362,13 @@ let descriptions =
    21, "Non-returning statement.";
    22, "Camlp4 warning.";
    23, "Useless record \"with\" clause.";
-   24, "Bad module name: the source file name is not a valid OCaml module name.";
+   24, "Bad module name: the source file name is not a valid OCaml module \
+        name.";
    25, "Pattern-matching with all clauses guarded.  Exhaustiveness cannot be\n\
-   \    checked";
-   26, "Suspicious unused variable: unused variable that is bound with \"let\"\n\
-   \    or \"as\", and doesn't start with an underscore (\"_\") character.";
+   \    checked.";
+   26, "Suspicious unused variable: unused variable that is bound\n\
+   \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+   \    character.";
    27, "Innocuous unused variable: unused variable that is not bound with\n\
    \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
    \    character.";
@@ -335,8 +376,30 @@ let descriptions =
    29, "Unescaped end-of-line in a string constant (non-portable code).";
    30, "Two labels or constructors of the same name are defined in two\n\
    \    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.";
   ]
+;;
 
 let help_warnings () =
   List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions;
+  print_endline "  A All warnings.";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Synonym for warning %i.\n" (Char.uppercase c) n
+    | l ->
+        Printf.printf "  %c Set of warnings %s.\n"
+          (Char.uppercase c)
+          (String.concat ", " (List.map string_of_int l))
+  done;
   exit 0
+;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index c9e577d9..c7542af8 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -45,6 +45,14 @@ type t =
   | 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 *)
 ;;
 
 val parse_options : bool -> string -> unit;;
diff --git a/win32caml/Makefile b/win32caml/Makefile
deleted file mode 100644
index a73b7315..00000000
--- a/win32caml/Makefile
+++ /dev/null
@@ -1,57 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            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.      #
-#                                                                       #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=$(BYTECCCOMPOPTS)
-
-OBJS=startocaml.$(O) ocamlres.$(O) ocaml.$(O) menu.$(O) \
-  history.$(O) editbuffer.$(O)
-
-LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \
-     $(call SYSLIB,user32) $(call SYSLIB,comdlg32) $(call SYSLIB,comctl32)
-
-all: ocamlwin.exe
-
-ocamlwin.exe: $(OBJS)
-	$(MKEXE) -o ocamlwin.exe $(OBJS) $(LIBS) $(EXTRALIBS) -subsystem windows
-
-ocamlres.$(O): ocaml.rc ocaml.ico
-ifeq ($(TOOLCHAIN),msvc)
-	rc ocaml.rc
-ifeq ($(ARCH),amd64)
-	cvtres /nologo /machine:amd64 /out:$@ ocaml.res
-else
-	cvtres /nologo /machine:ix86 /out:$@ ocaml.res
-endif
-	rm -f ocaml.res
-endif
-ifeq ($(TOOLCHAIN),mingw)
-	windres -i ocaml.rc -o $@
-endif
-
-$(OBJS): inria.h inriares.h history.h editbuffer.h
-
-clean:
-	rm -f ocamlwin.exe *.$(O) *.pdb ocamlwin.ilk
-
-install:
-	cp ocamlwin.exe $(PREFIX)/OCamlWin.exe
-
-.SUFFIXES: .c .$(O)
-
-.c.$(O):
-	$(CC) $(CFLAGS) -c $*.c
diff --git a/win32caml/editbuffer.c b/win32caml/editbuffer.c
deleted file mode 100644
index 480d22d8..00000000
--- a/win32caml/editbuffer.c
+++ /dev/null
@@ -1,514 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#include 
-#include 
-#include "inriares.h"
-#include "inria.h"
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_addline ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Adds a line to the current edit buffer
- Input:			Line of text to append to the end
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-	18 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Corrected doubly linked list issue
-------------------------------------------------------------------------*/
-BOOL editbuffer_addline(EditBuffer* edBuf, char* line)
-{
-	LineList *tail = NULL; //head of the edit buffer line list
-	LineList *newline = NULL;
-
-	// sanity check
-	if(edBuf == NULL)
-	{
-		return FALSE;
-	}
-
-	// perform edit buffer sanity checks
-	if((edBuf->LineCount < 0) || (edBuf->Lines == NULL))
-	{
-		edBuf->LineCount = 0;
-	}
-
-	// move to the end of the line list in the edit buffer
-	if((tail = edBuf->Lines) != NULL)
-		for( ; tail->Next != NULL; tail = tail->Next);
-
-	// create the new line entry
-	newline = (LineList*)SafeMalloc(sizeof(LineList));
-	newline->Next = NULL;
-	newline->Prev = tail;
-	newline->Text = (char*)SafeMalloc(strlen(line)+1);
-	strncpy(newline->Text, line, strlen(line)+1);
-	newline->Text[strlen(line)] = '\0';
-
-	// add it to the list as the head or the tail
-	if(tail != NULL)
-	{
-		tail->Next = newline;
-	} else {
-		edBuf->Lines = newline;
-	}
-
-	// update the number of lines in the buffer
-	edBuf->LineCount++;
-
-	return TRUE;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_updateline ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Updates the edit buffer's internal contents for a line
- Input:			idx - Line index
-				line - String to add
- Output:		if the line was updated or not
- Errors:
-------------------------------------------------------------------------*/
-BOOL editbuffer_updateline(EditBuffer* edBuf, int idx, char* line)
-{
-	LineList *update = edBuf->Lines; //head of the edit buffer line list
-	LineList *newline = NULL;
-	int i;
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return FALSE;
-	} else if(	(edBuf->LineCount == 0) ||
-				(edBuf->Lines == NULL) ||
-				(idx >= edBuf->LineCount) ||
-				(idx < 0) ) {
-		return FALSE;
-	}
-
-	// move to the index in the line list
-	// i left in update != NULL as a sanity check
-	for(i = 0; ((update != NULL) && (i != idx)); update = update->Next, i++);
-
-	// did things mess up?
-	if( (update == NULL) || (i != idx) )
-	{
-		return FALSE;
-	}
-
-	// get rid of the old line
-	free(update->Text);
-
-	// get the new line updated
-	update->Text = (char*)SafeMalloc(strlen(line)+1);
-	strncpy(update->Text, line, strlen(line)+1);
-	update->Text[strlen(line)] = '\0';
-
-	return TRUE;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_updateoraddline ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Updates the edit buffer's internal contents for a line
- Input:			idx - Line index
-				line - String to add
- Output:		if the line was updated or not
- Errors:
-------------------------------------------------------------------------*/
-BOOL editbuffer_updateoraddline(EditBuffer* edBuf, int idx, char* line)
-{
-	LineList *update;
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return FALSE;
-	} else if((idx > edBuf->LineCount) || (idx < 0)) {
-		return FALSE;
-	}
-
-	update = edBuf->Lines; //head of the edit buffer line list
-
-	// do we update or add?
-	if((idx < edBuf->LineCount) && (edBuf->Lines != NULL))
-	{	//interior line, update
-		return editbuffer_updateline(edBuf, idx, line);
-	} else {
-		//fence line, add
-		return editbuffer_addline(edBuf, line);
-	}
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_removeline ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Removes a line from the edit buffer
- Input:			idx - Line index to remove
- Output:		if the line was removed or not
- Errors:
---------------------------------------------------------------------------
- Edit History:
-	18 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added to allow backspace and delete support
-		- Corrected doubly linked list issue
-------------------------------------------------------------------------*/
-BOOL editbuffer_removeline(EditBuffer* edBuf, int idx)
-{
-	LineList *update = NULL;
-	int i = 0;
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return FALSE;
-	} else if(	(edBuf->LineCount == 0) ||
-				(edBuf->Lines == NULL) ||
-				(idx >= edBuf->LineCount) ||
-				(idx < 0) ) {
-		return FALSE;
-	}
-	
-	// move to the index in the line list
-	// i left in update != NULL as a sanity check
-	for(i = 0, update = edBuf->Lines; ((update != NULL) && (i != idx)); update = update->Next, i++);
-
-	// remove this line
-	if(update != NULL)
-	{
-		// break links, removing our line
-		if(update->Prev != NULL)
-		{
-			// we're not the first so just break the link
-			update->Prev->Next = update->Next;
-			
-			// fix the prev check
-			if(update->Next != NULL)
-				update->Next->Prev = update->Prev;
-		} else {
-			// we're the first, attach the next guy to lines
-			edBuf->Lines = update->Next;
-		}
-
-		// one less line to worry about
-		edBuf->LineCount--;
-
-		// get rid of the text
-		if(update->Text != NULL)
-			free(update->Text);
-
-		// get rid of us
-		free(update);
-
-		return TRUE;
-	}
-
-	return FALSE;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_getasline ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Returns the edit buffer as one big line, \n's and \t's
-				become spaces.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-char* editbuffer_getasline(EditBuffer* edBuf)
-{
-	LineList *line = NULL; //head of the edit buffer line list
-	char* retline = (char*)realloc(NULL, 1);
-	unsigned int i = 0;
-
-	// fix retline bug
-	retline[0] = '\0';
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return NULL;
-	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-		// fix any possible errors that may come from this
-		edBuf->LineCount = 0;
-		edBuf->Lines = NULL;
-		return NULL;
-	}
-
-	// get the big line
-	for(line = edBuf->Lines; line != NULL; line = line->Next)
-	{
-		if(line->Text != NULL)
-		{
-			retline = (char*)realloc(retline, (strlen(retline) + strlen(line->Text) + (strlen(retline) > 0 ? 2 : 1)));
-
-			if(strlen(retline) > 0)
-				retline = strcat(retline, " ");
-
-			retline = strcat(retline, line->Text);
-
-			//concat in the hoouuusssseee!
-		}
-	}
-
-	// now we have the big line, so lets ditch all \n's \t's and \r's
-	for(i = 0; i < strlen(retline); i++)
-	{
-		switch(retline[i])
-		{
-			case '\n':
-			case '\t':
-			case '\r':
-				retline[i] = ' ';
-		}
-	}
-
-	return retline;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_getasbuffer ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Returns the edit buffer as one big line, \n's and \t's
-				become spaces.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-char* editbuffer_getasbuffer(EditBuffer* edBuf)
-{
-	LineList *line = NULL; //head of the edit buffer line list
-	char* retbuf = (char*)realloc(NULL, 1);
-	unsigned int i = 0;
-
-	// fix retline bug
-	retbuf[0] = '\0';
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return NULL;
-	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-		// fix any possible errors that may come from this
-		edBuf->LineCount = 0;
-		edBuf->Lines = NULL;
-		return NULL;
-	}
-
-	// get the big line
-	for(line = edBuf->Lines; line != NULL; line = line->Next)
-	{
-		if(line->Text != NULL)
-		{
-			int len = strlen(retbuf);
-			len += strlen(line->Text) + (len > 0 ? 3 : 1);
-
-			retbuf = (char*)realloc(retbuf, len);
-
-			if(strlen(retbuf) > 0)
-				retbuf = strcat(retbuf, "\r\n");
-
-			retbuf = strcat(retbuf, line->Text);
-
-			retbuf[len-1] = '\0';
-
-			//concat in the hoouuusssseee!
-		}
-	}
-
-	return retbuf;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_lastline ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Returns the last line in the edit buffer
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-char* editbuffer_lastline(EditBuffer* edBuf)
-{
-	LineList *line = NULL; //head of the edit buffer line list
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return NULL;
-	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-		// fix any possible errors that may come from this
-		edBuf->LineCount = 0;
-		edBuf->Lines = NULL;
-		return NULL;
-	}
-
-	// go to the last line
-	for(line = edBuf->Lines; line->Next != NULL; line = line->Next);
-
-	return line->Text;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_copy ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Makes an exact copy of an edit buffer
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-	16 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added to make copies of history entries
-	18 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Corrected doubly linked list issue
-	06 Oct  2003 - Chris Watford watford@uiuc.edu
-		- Added isCorrect flag
-------------------------------------------------------------------------*/
-EditBuffer* editbuffer_copy(EditBuffer* edBuf)
-{
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return NULL;
-	} else {
-		EditBuffer* copy = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-		LineList* lines = edBuf->Lines;
-		LineList* lastLine = NULL;
-
-		// clear its initial values
-		copy->LineCount = 0;
-		copy->Lines = NULL;
-		copy->isCorrect = FALSE;
-
-		// well we don't have to copy much
-		if((lines == NULL) || (edBuf->LineCount <= 0))
-		{
-			return copy;
-		}
-
-		// get if its correct
-		copy->isCorrect = edBuf->isCorrect;
-
-		// go through each line, malloc it and add it
-		for( ; lines != NULL; lines = lines->Next)
-		{
-			LineList* curline = (LineList*)SafeMalloc(sizeof(LineList));
-			curline->Next = NULL;
-			curline->Prev = NULL;
-
-			// if there was a last line, link them to us
-			if(lastLine != NULL)
-			{
-				lastLine->Next = curline;
-				curline->Prev = lastLine;
-			}
-
-			// are we the first line? add us to the edit buffer as the first
-			if(copy->Lines == NULL)
-			{
-				copy->Lines = curline;
-			}
-
-			// check if there is text on the line
-			if(lines->Text == NULL)
-			{	// no text, make it blankz0r
-				curline->Text = (char*)SafeMalloc(sizeof(char));
-				curline->Text[0] = '\0';
-			} else {
-				// there is text, copy it and null-terminate
-				curline->Text = (char*)SafeMalloc(strlen(lines->Text) + 1);
-				strncpy(curline->Text, lines->Text, strlen(lines->Text));
-				curline->Text[strlen(lines->Text)] = '\0';
-			}
-
-			// up the line count and make us the last line
-			copy->LineCount++;
-			lastLine = curline;
-		}
-
-		// return our new copy
-		return copy;
-	}
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_destroy ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Destroys an edit buffer
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-void editbuffer_destroy(EditBuffer* edBuf)
-{
-	// sanity checks
-	if(edBuf == NULL)
-	{	// nothing to do
-		return;
-	} else if(edBuf->Lines != NULL) {
-		LineList* lastline = NULL;
-
-		// loop through each line free'ing its text
-		for( ; edBuf->Lines != NULL; edBuf->Lines = edBuf->Lines->Next)
-		{
-			if(edBuf->Lines->Text != NULL)
-				free(edBuf->Lines->Text);
-
-			// if there was a line before us, free it
-			if(lastline != NULL)
-			{
-				free(lastline);
-				lastline = NULL;
-			}
-
-			lastline = edBuf->Lines;
-		}
-
-		// free the last line
-		free(lastline);
-	}
-
-	// free ourself
-	free(edBuf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_new ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Creates an edit buffer
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-	06 Oct  2003 - Chris Watford watford@uiuc.edu
-		- Added isCorrect flag
-------------------------------------------------------------------------*/
-EditBuffer* editbuffer_new(void)
-{
-	// create a new one
-	EditBuffer *edBuf = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-	
-	// default vals
-	edBuf->LineCount = 0;
-	edBuf->Lines = NULL;
-	edBuf->isCorrect = FALSE;
-	
-	// return it
-	return edBuf;
-}
diff --git a/win32caml/editbuffer.h b/win32caml/editbuffer.h
deleted file mode 100644
index 91e2999c..00000000
--- a/win32caml/editbuffer.h
+++ /dev/null
@@ -1,47 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#ifndef _EDITBUFFER_H_
-#define _EDITBUFFER_H_
-
-// All the below was added by Chris Watford watford@uiuc.edu
-
-typedef struct tagLineList {
-        struct tagLineList	*Next;
-		struct tagLineList	*Prev;
-        char				*Text;
-} LineList;
-
-typedef struct tagEditBuffer {
-	int					LineCount;
-	struct tagLineList	*Lines;
-	BOOL				isCorrect;
-} EditBuffer;
-
-BOOL		editbuffer_addline			(EditBuffer* edBuf, char* line);
-BOOL		editbuffer_updateline		(EditBuffer* edBuf, int idx, char* line);
-BOOL		editbuffer_updateoraddline	(EditBuffer* edBuf, int idx, char* line);
-BOOL		editbuffer_removeline		(EditBuffer* edBuf, int idx);
-char*		editbuffer_getasline		(EditBuffer* edBuf);
-char*		editbuffer_getasbuffer		(EditBuffer* edBuf);
-char*		editbuffer_lastline			(EditBuffer* edBuf);
-EditBuffer*	editbuffer_copy				(EditBuffer* edBuf);
-void		editbuffer_destroy			(EditBuffer* edBuf);
-EditBuffer*	editbuffer_new				(void);
-
-#endif
diff --git a/win32caml/history.c b/win32caml/history.c
deleted file mode 100644
index 11397ac6..00000000
--- a/win32caml/history.c
+++ /dev/null
@@ -1,98 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#include "inria.h"
-#include "history.h"
-
-/*------------------------------------------------------------------------
-Procedure:     AddToHistory ID:2
-Author:		   Chris Watford watford@uiuc.edu
-Purpose:       Adds an edit buffer to the history control
-Input:		   Pointer to the edit buffer to add
-Output:
-Errors:
---------------------------------------------------------------------------
-Edit History:
-	15 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Complete rewrite
-		- Got it to add the edit buffer to the history
-	17 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added doubly link list support
-------------------------------------------------------------------------*/
-void AddToHistory(EditBuffer *edBuf)
-{
-	StatementHistory *newLine;
-
-	// sanity checks
-	if(edBuf == NULL)
-	{
-		return;
-	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-		// fix any possible errors that may come from this
-		edBuf->LineCount = 0;
-		edBuf->Lines = NULL;
-		return;
-	}
-
-	// setup newline and add as the front of the linked list
-	newLine = SafeMalloc(sizeof(StatementHistory));
-	newLine->Next = History;
-	newLine->Prev = NULL;
-	newLine->Statement = edBuf;
-
-	// setup back linking
-	if(History != NULL)
-		History->Prev = newLine;
-
-	// set the history up
-	History = newLine;
-
-	// search for the new history tail
-	for(HistoryTail = (HistoryTail != NULL ? HistoryTail : History); HistoryTail->Next != NULL; HistoryTail = HistoryTail->Next);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GetHistoryLine ID:2
-Author:		   Chris Watford watford@uiuc.edu
-Purpose:       Returns an entry from the history table
-Input:		   Index of the history entry to return
-Output:		   The history entry as a single line
-Errors:
---------------------------------------------------------------------------
-Edit History:
-	15 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Complete rewrite
-	17 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added doubly link list support
-------------------------------------------------------------------------*/
-char *GetHistoryLine(int n)
-{
-	StatementHistory *histentry = History;
-	int i;
-
-	// traverse linked list looking for member n
-	for (i = 0; ((i < n) && (histentry != NULL)); i++, histentry = histentry->Next);
-
-	// figure out what to return
-	if (histentry != NULL)
-	{
-		return editbuffer_getasline(histentry->Statement);
-	} else {
-		return "";
-	}
-}
diff --git a/win32caml/history.h b/win32caml/history.h
deleted file mode 100644
index a9ba8584..00000000
--- a/win32caml/history.h
+++ /dev/null
@@ -1,35 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#ifndef _HISTORY_H_
-#define _HISTORY_H_
-
-#include "editbuffer.h"
-
-// Simple linked list for holding the history lines
-typedef struct tagStatementHistory {
-        struct tagStatementHistory	*Next;
-		struct tagStatementHistory	*Prev;
-        EditBuffer					*Statement;
-} StatementHistory;
-
-void	AddToHistory	(EditBuffer *edBuf);
-char	*GetHistoryLine	(int n);
-static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam);
-
-#endif
diff --git a/win32caml/inria.h b/win32caml/inria.h
deleted file mode 100644
index 095cbcc7..00000000
--- a/win32caml/inria.h
+++ /dev/null
@@ -1,134 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/*------------------------------------------------------------------------
- Module:        D:\lcc\inria\inria.h
- Author:        Jacob
- Project:
- State:
- Creation Date: June 2001
- Description:   The user interface works as follows:
-                1: At startup it will look for the path to the
-                ocaml interpreter in the registry using the
-                key HKEY_CURRENT_USER\SOFTWARE\ocaml. If not
-                found will prompt the user.
-                2: It will start the ocaml interpreter with
-                its standard output and standard input
-                connected to two pipes in a dedicated thread.
-                3: It will open a window containing an edit
-                field. The output from the interpreter will be
-                shown in the edit field, and the input of the
-                user in the edit field will be sent to the
-                interpreter when the user types return.
-                4: Line editing is provided by moving to the
-                desired line with the arrows, then pressing
-                return; If we aren't in the last input line,
-                the input will be copied to the last line and
-                sent to the interpreter.
-                5: The GUI ensures that when we exit the ocaml
-                interpreter is stopped by sending the
-                character string "#quit;;\nCtrl-Z"
-                6: A history of all lines sent to the interpreter
-                is maintained in a simple linked list. The
-                History dialog box shows that, and allows the
-                user to choose a given input line.
-                7: Memory limits. The edit buffer can be of an
-                arbitrary length, i.e. maybe 7-8MB or more,
-                there are no fixed limits. The History list
-                will always grow too, so memory consumption
-                could be "high" after several days of
-                uninterrupted typing at the keyboard. For that
-                cases it is recommended to stop the GUI and
-                get some sleep...
-                9: The GUI will start a timer, looking 4 times a
-                second if the interpreter has written
-                something in the pipe. This is enough for most
-                applications.
-------------------------------------------------------------------------*/
-#ifndef _INRIA_H_
-#define _INRIA_H_
-
-#include 
-#include "editbuffer.h"
-#include "history.h"
-
-#if _MSC_VER <= 1200 && !defined(__MINGW32__)
-#define GetWindowLongPtr GetWindowLong
-#define SetWindowLongPtr SetWindowLong
-#define DWLP_USER DWL_USER
-#define GWLP_WNDPROC GWL_WNDPROC
-#define LONG_PTR DWORD
-#endif
-
-// In this structure should go eventually all global variables scattered
-// through the program.
-typedef struct _programParams {
-        HFONT hFont;                                    // The handle of the current font
-        COLORREF TextColor;                             // The text color
-        char CurrentWorkingDir[MAX_PATH];// The current directory
-} PROGRAM_PARAMS;
-
-//**************** Global variables ***********************
-extern PROGRAM_PARAMS ProgramParams;
-
-extern COLORREF BackColor;                      // The background color
-extern HBRUSH BackgroundBrush;          // A brush built with the background color
-extern char LibDir[];                           // The lib directory
-extern char OcamlPath[];                        // The Path to ocaml.exe
-extern HANDLE hInst;                            // The instance handle for this application
-extern HWND hwndSession;                        // The current session window handle
-extern LOGFONT CurrentFont;                     // The current font characteristics
-extern HWND hwndMain,hwndMDIClient; // Window handles of frame and mdi window
-
-// ***************** Function prototypes ******************
-int WriteToPipe(char *data);            // Writes to the pipe
-int ReadFromPipe(char *data,int len);// Reads from the pipe
-int AskYesOrNo(char *msg);                      //Ditto!
-int BrowseForFile(char *fname,char *path);
-void GotoEOF(void);                                     // Positions the cursor at the end of the text
-void ShowDbgMsg(char *msg);                     // Shows an error message
-void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam);
-int GetOcamlPath(void);                         // Finds where ocaml.exe is
-void ForceRepaint(void);                        // Ditto.
-void AddLineToControl(char *buf);
-void AddStringToControl(char* buf);
-char *GetHistoryLine(int n);            // Gets the nth history line base 1.
-int StartOcaml(void);
-void InterruptOcaml(void);
-int ResetText(void);
-BOOL SendingFullCommand(void);
-void RewriteCurrentEditBuffer(void);
-void RefreshCurrentEditBuffer(void);
-
-// **************** User defined window messages *************
-#define WM_NEWLINE		(WM_USER+6000)
-#define WM_TIMERTICK	(WM_USER+6001)
-#define WM_QUITOCAML	(WM_USER+6002)
-#define WM_SYNTAXERROR	(WM_USER+6003)
-#define WM_UNBOUNDVAL	(WM_USER+6004)
-#define WM_ILLEGALCHAR	(WM_USER+6005)
-
-// ********************** Structures ***********************
-typedef struct tagPosition {
-        int line;
-        int col;
-} POSITION;
-
-extern void *SafeMalloc(int);
-extern StatementHistory *History; // The root of the history lines
-extern StatementHistory *HistoryTail; // The tail of the history lines
-extern EditBuffer *CurrentEditBuffer; // current edit buffer
-
-#define IDEDITCONTROL 15432
-#endif
diff --git a/win32caml/inriares.h b/win32caml/inriares.h
deleted file mode 100644
index 2043a37d..00000000
--- a/win32caml/inriares.h
+++ /dev/null
@@ -1,48 +0,0 @@
-/* Weditres generated include file. Do NOT edit */
-#define IDD_ABOUT       100
-#define IDM_NEW 200
-#define IDM_OPEN        210
-#define IDM_SAVE        220
-#define IDM_SAVEAS      230
-#define IDM_CLOSE       240
-#define IDM_PRINT       250
-#define IDM_PRINTSU     260
-#define IDM_PRINTPRE    265
-#define IDM_PAGESETUP   267
-#define IDM_EXIT        270
-#define IDM_HISTORY     281
-#define IDM_GC  282
-#define IDCTRLC 283
-#define IDD_HISTORY     300
-#define IDLIST  301
-#define IDM_EDITUNDO    310
-#define IDM_EDITCUT     320
-#define IDM_EDITCOPY    330
-#define IDM_EDITPASTE   340
-#define IDM_EDITCLEAR   350
-#define IDM_EDITDELETE  360
-#define IDM_EDITREPLACE 370
-#define IDM_EDITREDO    380
-#define IDM_WINDOWTILE  410
-#define IDM_WINDOWCASCADE       420
-#define IDM_WINDOWICONS 430
-#define IDM_WINDOWCLOSEALL      440
-#define IDM_PROPERTIES  450
-#define IDM_ABOUT       500
-#define IDM_HELP        510
-#define IDMAINMENU      600
-#define IDM_FIND        700
-#define IDAPPLICON      710
-#define IDI_CHILDICON   800
-#define IDAPPLCURSOR    810
-#define OCAML_ICON      1000
-#define IDS_FILEMENU    2000
-#define IDS_HELPMENU    2010
-#define IDS_SYSMENU     2030
-#define IDM_STATUSBAR   3000
-#define IDM_WINDOWCHILD 3010
-#define ID_TOOLBAR      5000
-#define IDACCEL 10000
-#define IDM_FONT        40002
-#define IDM_COLORTEXT   40004
-#define IDM_BACKCOLOR   40005
diff --git a/win32caml/libgraph.h b/win32caml/libgraph.h
deleted file mode 100644
index 3bfaff30..00000000
--- a/win32caml/libgraph.h
+++ /dev/null
@@ -1,108 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include 
-#include 
-
-struct canvas {
-  int w, h;                     /* Dimensions of the drawable */
-  HWND win;                     /* The drawable itself */
-  HDC gc;                        /* The associated graphics context */
-};
-
-extern HWND grdisplay;     /* The display connection */
-//extern int grscreen;            /* The screen number */
-//extern Colormap grcolormap;     /* The color map */
-//extern struct canvas grwindow;  /* The graphics window */
-//extern struct canvas grbstore;  /* The pixmap used for backing store */
-//extern int grwhite, grblack;    /* Black and white pixels for X */
-//extern int grbackground;        /* Background color for X
-//                                   (used for CAML color -1) */
-extern COLORREF grbackground;
-extern BOOL grdisplay_mode;     /* Display-mode flag */
-extern BOOL grremember_mode;    /* Remember-mode flag */
-extern int grx, gry;            /* Coordinates of the current point */
-extern int grcolor;             /* Current *CAML* drawing color (can be -1) */
-extern HFONT * grfont;          /* Current font */
-
-extern BOOL direct_rgb;
-extern int byte_order;
-extern int bitmap_unit;
-extern int bits_per_pixel;
-
-#define Wcvt(y) (grwindow.height - 1 - (y))
-#define Bcvt(y) (grwindow.height - 1 - (y))
-#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h)
-//#define BtoW(y) ((y) + WindowRect.bottom - grbstore.h)
-
-#define DEFAULT_SCREEN_WIDTH 1024
-#define DEFAULT_SCREEN_HEIGHT 768
-#define BORDER_WIDTH 2
-#define WINDOW_NAME "Caml graphics"
-#define ICON_NAME "Caml graphics"
-#define DEFAULT_EVENT_MASK \
-          (ExposureMask | KeyPressMask | StructureNotifyMask)
-#define DEFAULT_FONT "fixed"
-#define SIZE_QUEUE 256
-
-/* To handle events asynchronously */
-#ifdef HAS_ASYNC_IO
-#define USE_ASYNC_IO
-#define EVENT_SIGNAL SIGIO
-#else
-#ifdef HAS_SETITIMER
-#define USE_INTERVAL_TIMER
-#define EVENT_SIGNAL SIGALRM
-#else
-#define USE_ALARM
-#define EVENT_SIGNAL SIGALRM
-#endif
-#endif
-
-void gr_fail(char *fmt, char *arg);
-void gr_check_open(void);
-unsigned long gr_pixel_rgb(int rgb);
-int gr_rgb_pixel(long unsigned int pixel);
-void gr_enqueue_char(unsigned char c);
-void gr_init_color_cache(void);
-
-// Windows specific definitions
-extern RECT WindowRect;
-extern int grCurrentColor;
-
-typedef struct tagWindow {
-        HDC gc;
-        HDC gcBitmap;
-        HWND hwnd;
-        HBRUSH CurrentBrush;
-        HPEN CurrentPen;
-        DWORD CurrentColor;
-        int width;
-        int height;
-        int grx;
-        int gry;
-        HBITMAP hBitmap;
-        HFONT CurrentFont;
-        int CurrentFontSize;
-        HDC tempDC; // For image operations;
-} GR_WINDOW;
-
-extern GR_WINDOW grwindow;
-HFONT CreationFont(char *name);
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern HANDLE EventHandle;
-extern int InspectMessages;
-extern MSG msg;
-
diff --git a/win32caml/menu.c b/win32caml/menu.c
deleted file mode 100644
index 9ab0f5f3..00000000
--- a/win32caml/menu.c
+++ /dev/null
@@ -1,830 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include 
-#include 
-#include 
-#include "inria.h"
-#include "inriares.h"
-#include "history.h"
-
-LOGFONT CurrentFont;
-int CurrentFontFamily = (FIXED_PITCH | FF_MODERN);
-int CurrentFontStyle;
-char CurrentFontName[64] = "Courier";
-
-/*------------------------------------------------------------------------
- Procedure:     OpenMlFile ID:1
- Purpose:       Opens a file, either a source file (*.ml) or an *.cmo
-                file.
- Input:         A buffer where the name will be stored, and its
-                length
- Output:        The user's choice will be stored in the buffer.
- Errors:        None
-------------------------------------------------------------------------*/
-int OpenMlFile(char *fname,int lenbuf)
-{
-        OPENFILENAME ofn;
-        int r;
-        char *p,defext[5],tmp[512];
-
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        memset(tmp,0,sizeof(tmp));
-        fname[0] = 0;
-        strcpy(tmp,"ocaml sources|*.ml|bytecode object files|*.cmo|All files|*.*");
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        strcpy(defext,"ml");
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.hInstance = hInst;
-        ofn.lpstrFile = fname;
-        ofn.lpstrTitle = "Open file";
-        ofn.lpstrInitialDir = LibDir;
-        ofn.nMaxFile = lenbuf;
-        ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetOpenFileName(&ofn);
-        if (r) {
-          /* Replace backslashes by forward slashes in file name */
-          for (p = fname; *p != 0; p++)
-            if (*p == '\\') *p = '/';
-        }
-        return r;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     GetSaveName ID:1
- Purpose:       Get a name to save the current session (Save as menu
-                item)
- Input:         A buffer where the name of the file will be stored,
-                and its length
- Output:        The name of the file choosen by the user will be
-                stored in the buffer
- Errors:        none
-------------------------------------------------------------------------*/
-int GetSaveName(char *fname,int lenbuf)
-{
-        OPENFILENAME ofn;
-        int r;
-        char *p,defext[5],tmp[512];
-
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        memset(tmp,0,sizeof(tmp));
-        fname[0] = 0;
-        strcpy(tmp,"Text files|*.txt");
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        strcpy(defext,"txt");
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.hInstance = hInst;
-        ofn.lpstrFile = fname;
-        ofn.lpstrTitle = "Save as";
-        ofn.lpstrInitialDir = LibDir;
-        ofn.nMaxFile = lenbuf;
-        ofn.Flags =  OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetSaveFileName(&ofn);
-        if (r == 0)
-                return 0;
-        else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     GetSaveMLName ID:1
- Purpose:       Get a name to save the current OCaml code to (Save as menu
-                item)
- Input:         A buffer where the name of the file will be stored,
-                and its length
- Output:        The name of the file choosen by the user will be
-                stored in the buffer
- Errors:        none
-------------------------------------------------------------------------*/
-int GetSaveMLName(char *fname, int lenbuf)
-{
-        OPENFILENAME ofn;
-        int r;
-        char *p,defext[5],tmp[512];
-
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        memset(tmp,0,sizeof(tmp));
-        fname[0] = 0;
-        strcpy(tmp,"OCaml Source Files|*.ml");
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        strcpy(defext,"ml");
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.hInstance = hInst;
-        ofn.lpstrFile = fname;
-        ofn.lpstrTitle = "Save as";
-        ofn.lpstrInitialDir = LibDir;
-        ofn.nMaxFile = lenbuf;
-        ofn.Flags =  OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetSaveFileName(&ofn);
-        if (r == 0)
-                return 0;
-        else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     BrowseForFile ID:1
- Purpose:       Let's the user browse for a certain kind of file.
-                Currently this is only used when browsing for
-                ocaml.exe.
- Input:         The name of the file to browse for, and the path
-                where the user's choice will be stored.
- Output:        1 if user choosed a path, zero otherwise
- Errors:        None
-------------------------------------------------------------------------*/
-int BrowseForFile(char *fname,char *path)
-{
-        OPENFILENAME ofn;
-        char *p,tmp[512],browsefor[512];
-        int r;
-
-        memset(tmp,0,sizeof(tmp));
-        strncpy(tmp,fname,sizeof(tmp)-1);
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.hInstance = hInst;
-        ofn.lpstrFilter = tmp;
-        ofn.lpstrFile = path;
-        wsprintf(browsefor,"Open %s",fname);
-        ofn.lpstrTitle = browsefor;
-        ofn.lpstrInitialDir = "c:\\";
-        ofn.nMaxFile = MAX_PATH;
-        ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetOpenFileName(&ofn);
-        if (r == 0)
-                return 0;
-        else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CallChangeFont ID:1
- Purpose:       Calls the standard windows font change dialog. If the
-                user validates a font, it will destroy the current
-                font, and recreate a new font with the given
-                parameters.
- Input:         The calling window handle
- Output:        Zero if the user cancelled, 1 otherwise.
- Errors:        None
-------------------------------------------------------------------------*/
-static int CallChangeFont(HWND hwnd)
-{
-        LOGFONT lf;
-        CHOOSEFONT cf;
-        int r;
-        HWND hwndChild;
-
-        memset(&cf, 0, sizeof(CHOOSEFONT));
-        memcpy(&lf, &CurrentFont, sizeof(LOGFONT));
-        cf.lStructSize = sizeof(CHOOSEFONT);
-        cf.hwndOwner = hwnd;
-        cf.lpLogFont = &lf;
-        cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_APPLY | CF_INITTOLOGFONTSTRUCT;
-        cf.nFontType = SCREEN_FONTTYPE;
-        r = ChooseFont(&cf);
-        if (!r)
-                return (0);
-        DeleteObject(ProgramParams.hFont);
-        memcpy(&CurrentFont, &lf, sizeof(LOGFONT));
-        ProgramParams.hFont = CreateFontIndirect(&CurrentFont);
-        strcpy(CurrentFontName, CurrentFont.lfFaceName);
-        CurrentFontFamily = lf.lfPitchAndFamily;
-        CurrentFontStyle = lf.lfWeight;
-    hwndChild = (HWND) GetWindowLongPtr(hwndSession, DWLP_USER);
-        SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
-        ForceRepaint();
-        return (1);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CallDlgProc ID:1
- Purpose:       Calls a dialog box procedure
- Input:         The function to call, and the numerical ID of the
-                resource where the dialog box is stored
- Output:        Returns the result of the dialog box.
- Errors:        None
-------------------------------------------------------------------------*/
-int CallDlgProc(BOOL (CALLBACK *fn)(HWND,UINT,WPARAM,LPARAM), int id)
-{
-   int result;
-
-   result = DialogBoxParam(hInst, MAKEINTRESOURCE(id), GetActiveWindow(),
-                        fn, 0);
-   return result;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure:     CallChangeColor ID:1
- Purpose:       Calls the standard color dialog of windows, starting
-                with the given color reference. The result is the
-                same as the input if the user cancels, or another
-                color if the user validates another one.
- Input:         The starting color
- Output:        The color the user has choosen.
- Errors:        None
-------------------------------------------------------------------------*/
-static COLORREF CallChangeColor(COLORREF InitialColor)
-{
-        CHOOSECOLOR CC;
-        COLORREF CustColors[16];
-        int r, g, b, i;
-        memset(&CC, 0, sizeof(CHOOSECOLOR));
-        r = g = b = 0;
-        for (i = 0; i < 16; i++) {
-                CustColors[i] = RGB(r, g, b);
-                if (r < 255)
-                        r += 127;
-                else if (g < 255)
-                        g += 127;
-                else if (b < 255)
-                        g += 127;
-        }
-        CC.lStructSize = sizeof(CHOOSECOLOR);
-        CC.hwndOwner = hwndMain;
-        CC.hInstance = hInst;
-        CC.rgbResult = InitialColor;
-        CC.lpCustColors = CustColors;
-        CC.Flags = CC_RGBINIT;
-        if (!ChooseColor(&CC))
-                return (InitialColor);
-        return (CC.rgbResult);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CallPrintSetup ID:1
- Purpose:       Calls the printer setup dialog. Currently it is not
-                connected to the rest of the software, since printing
-                is not done yet
- Input:         None
- Output:        1 if OK, 0, user cancelled
- Errors:        None
-------------------------------------------------------------------------*/
-static int CallPrintSetup(void)
-{
-        PAGESETUPDLG sd;
-        int r;
-
-        memset(&sd,0,sizeof(sd));
-        sd.lStructSize = sizeof(sd);
-        sd.Flags = PSD_RETURNDEFAULT;
-        r = PageSetupDlg(&sd);
-        if (!r)
-                return 0;
-        sd.Flags = 0;
-        r = PageSetupDlg(&sd);
-        return r;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure:     Undo ID:1
- Purpose:       Send an UNDO command to the edit field.
- Input:         The parent window of the control
- Output:        None
- Errors:        None
-------------------------------------------------------------------------*/
-void Undo(HWND hwnd)
-{
-        HWND hEdit;
-
-        hEdit = (HWND)GetWindowLongPtr(hwnd,DWLP_USER);
-        SendMessage(hEdit,EM_UNDO,0,0);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     ForceRepaint ID:1
- Purpose:       Forces a complete redraw of the edit control of the
-                current session.
- Input:         None
- Output:        None
- Errors:        None
-------------------------------------------------------------------------*/
-void ForceRepaint(void)
-{
-        HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        InvalidateRect(hwndEdit,NULL,1);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     Add_Char_To_Queue ID:1
- Purpose:       Puts a character onto the buffer
- Input:         The char to be added
- Output:        None
- Errors:
-------------------------------------------------------------------------*/
-static void Add_Char_To_Queue(int c)
-{
-        HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        SendMessage(hwndEdit,WM_CHAR,c,1);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     AddLineToControl ID:1
- Purpose:       It will ad the given text at the end of the edit
-                control, then it will send a return character to it.
-                This simulates user input. The history will not be
-                modified by this procedure.
- Input:         The text to be added
- Output:        None
- Errors:        If the line is empty, nothing will be done
-------------------------------------------------------------------------*/
-void AddLineToControl(char *buf)
-{
-        HWND hEditCtrl;
-
-        if (*buf == 0)
-                return;
-
-        hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-
-        GotoEOF();
-
-        SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf);
-        SendMessage(hEditCtrl,WM_CHAR,'\r',0);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     AddStringToControl ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       It will ad the given text at the end of the edit
-                control. This simulates user input. The history will not
-				be modified by this procedure.
- Input:         The text to be added
- Output:        None
- Errors:        If the line is empty, nothing will be done
---------------------------------------------------------------------------
-Edit History:
-	16 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Basically this is AddLineToControl, but without appending a
-		  newline
-------------------------------------------------------------------------*/
-void AddStringToControl(char* buf)
-{
-        HWND hEditCtrl;
-
-		if(buf == NULL)
-			return;
-
-        if((*buf) == 0)
-            return;
-
-        hEditCtrl = (HWND)GetWindowLongPtr(hwndSession, DWLP_USER);
-        GotoEOF();
-
-        SendMessage(hEditCtrl ,EM_REPLACESEL, (WPARAM)FALSE, (LPARAM)buf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     AboutDlgProc ID:1
- Purpose:       Shows the "About" dialog box
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
-{
-        if (message == WM_CLOSE)
-                EndDialog(hDlg,1);
-        return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     HistoryDlgProc ID:1
- Purpose:       Shows the history of the session. Only input lines
-                are shown. A double click in a line will make this
-                dialog box procedure return the index of the selected
-                line (1 based). If the windows is closed (what is
-                equivalent to cancel), the return value is zero.
- Input:         Normal windows callback
- Output:
- Errors:
---------------------------------------------------------------------------
-Edit History:
-	15 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added support for my StatementHistory structure
-		- Added the ability to export it as its exact entry, rather than
-		  just a 1 liner
-------------------------------------------------------------------------*/
-static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
-{
-        StatementHistory *histentry;
-        int idx;
-        RECT rc;
-
-        switch (message) {
-                case WM_INITDIALOG:
-                        SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
-                        histentry = History; // get our statement history object
-                        idx = 0;
-
-						// loop through each history entry adding it to the dialog
-                        while (histentry != NULL) {
-                                SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)editbuffer_getasline(histentry->Statement));
-                                SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx);
-                                histentry = histentry->Next;
-                                idx++;
-                        }
-
-                        SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0);
-                        return 1;
-                case WM_COMMAND:
-                        switch(LOWORD(wParam)) {
-                                case IDLIST:
-                                        switch(HIWORD(wParam)) {
-                                                case LBN_DBLCLK:
-                                                        idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETCURSEL,0,0);
-                                                        if (idx == LB_ERR)
-                                                                break;
-                                                        idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETITEMDATA,idx,0);
-                                                        EndDialog(hDlg,idx+1);
-                                                        return 1;
-                                        }
-                                        break;
-                        }
-                        break;
-                case WM_SIZE:
-                        GetClientRect(hDlg,&rc);
-                        MoveWindow(GetDlgItem(hDlg,IDLIST),0,0,rc.right,rc.bottom,1);
-                        break;
-
-                case WM_CLOSE:
-                        EndDialog(hDlg,0);
-                        break;
-        }
-        return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     SaveText ID:1
- Purpose:       Saves the contents of the session transcript. It will
-                loop for each line and write it to the specified file
- Input:         The name of the file where the session will be saved
- Output:        The session is saved
- Errors:        If it can't open the file for writing it will show an
-                error box
---------------------------------------------------------------------------
- Edit History:
-	06 Oct  2003 - Chris Watford watford@uiuc.edu
-		- Corrected wsprintf error
-------------------------------------------------------------------------*/
-static void SaveText(char *fname)
-{
-        int i,len;
-        HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-        FILE *f;
-        char *buf = SafeMalloc(8192);
-
-        f = fopen(fname,"wb");
-        if (f == NULL)
-		{
-			// corrected error using wsprintf
-            wsprintf(buf, "Impossible to open %s for writing", fname);
-
-            ShowDbgMsg(buf);
-            return;
-        }
-
-        for (i = 0; i < linesCount; i++)
-		{
-                *(unsigned short *)buf = 8100;
-                len = SendMessage(hEdit, EM_GETLINE, i, (LPARAM)buf);
-                buf[len] = '\0';
-				fprintf(f, "%s\r\n", buf+1);
-                //fwrite(buf,1,len+2,f);
-        }
-
-        fclose(f);
-        free(buf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     SaveML ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Saves the ML source to a file, commenting out functions
-				that contained errors
- Input:         The name of the file where the session will be saved
- Output:        The session is saved
- Errors:        If it can't open the file for writing it will show an
-                error box
-------------------------------------------------------------------------*/
-static void SaveML(char *fname)
-{
-        FILE *f;
-        char *buf = SafeMalloc(8192);
-
-        f = fopen(fname, "wb");
-
-        if(f == NULL)
-		{
-                wsprintf(buf, "Impossible to open %s for writing", fname);
-                ShowDbgMsg(buf);
-                return;
-        }
-
-		fprintf(f, "(* %s *)\r\n\r\n", fname);
-
-		if(History != NULL)
-		{
-			StatementHistory *h = NULL;
-			EditBuffer *stmt = NULL;
-
-			// get to the end
-			for(h = History; h->Next != NULL; h = h->Next);
-
-			// go back :(
-			// this is NOT the fastest method, BUT this is the easiest
-			// on the subsystem
-			for(; h != NULL; h = h->Prev)
-			{
-				stmt = h->Statement;
-
-				if(stmt != NULL)
-				{
-					// comment out incorrect lines
-					if(stmt->isCorrect)
-					{
-						char *buff = editbuffer_getasbuffer(stmt);
-						fprintf(f, "%s\r\n", buff);
-						free(buff);
-					} else {
-						char *buff = editbuffer_getasbuffer(stmt);
-						fprintf(f, "(* Syntax Error or Unbound Value\r\n%s\r\n *)\r\n", buff);
-						free(buff);
-					}
-				}
-
-				fprintf(f, "\r\n");
-			}
-		}
-
-        fclose(f);
-        free(buf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     Add_Clipboard_To_Queue ID:1
- Author:		Chris Watford watford@uiuc.edu
- Purpose:       Adds the clipboard text to the control
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-	16 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added method to update edit buffer with paste contents
-------------------------------------------------------------------------*/
-static void Add_Clipboard_To_Queue(void)
-{
-    if (IsClipboardFormatAvailable(CF_TEXT) && OpenClipboard(hwndMain))
-    {
-        HANDLE hClipData = GetClipboardData(CF_TEXT);
-
-        if (hClipData != NULL)
-        {
-            char *str = GlobalLock(hClipData);
-
-            if (str != NULL)
-			{
-                while ((*str) != 0)
-                {
-                    if (*str != '\r')
-                        Add_Char_To_Queue(*str);
-
-                    str++;
-                }
-
-				// added to fix odd errors
-				RefreshCurrentEditBuffer();
-			}
-
-            GlobalUnlock(hClipData);
-        }
-
-        CloseClipboard();
-    }
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CopyToClipboard ID:1
- Purpose:       Copies text to the clipboard
- Input:			Window with the edit control
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static void CopyToClipboard(HWND hwnd)
-{
-        HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        SendMessage(hwndEdit,WM_COPY,0,0);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     ResetText ID:1
- Purpose:       Resets the text? I'm not really sure
- Input:
- Output:		Always returns 0
- Errors:
-------------------------------------------------------------------------*/
-int ResetText(void)
-{
-        HWND hwndEdit = (HWND) GetWindowLongPtr(hwndSession,DWLP_USER);
-        TEXTRANGE cr;
-        int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0);
-        char *tmp = malloc(len+10),*p;
-
-        memset(tmp,0,len+10);
-        cr.chrg.cpMin = 0;
-        cr.chrg.cpMax = -1;
-        cr.lpstrText = tmp;
-        SendMessage(hwndEdit,EM_GETTEXTRANGE,0,(LPARAM)&cr);
-        p = tmp+len/2;
-        while (*p && *p != '\r')
-                p++;
-        SendMessage(hwndEdit,EM_SETSEL,0,(LPARAM)-1);
-        SendMessage(hwndEdit,EM_REPLACESEL,0,(LPARAM)p);
-        InvalidateRect(hwndEdit,0,1);
-        free(tmp);
-        return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     HandleCommand ID:1
- Purpose:       Handles all menu commands.
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-	06 Oct  2003 - Chris Watford watford@uiuc.edu
-		- Removed entries that crashed OCaml
-		- Removed useless entries
-		- Added Save ML and Save Transcript
-------------------------------------------------------------------------*/
-void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
-{
-        char *fname;
-        int r;
-
-        switch(LOWORD(wParam)) {
-                case IDM_OPEN:
-                        fname = SafeMalloc(512);
-                        if (OpenMlFile(fname,512)) {
-                                char *buf = SafeMalloc(512);
-                                char *p = strrchr(fname,'.');
-                                if (p && !stricmp(p,".ml")) {
-                                        wsprintf(buf, "#use \"%s\";;", fname);
-                                        AddLineToControl(buf);
-                                }
-                                else if (p && !stricmp(p,".cmo")) {
-                                        wsprintf(buf, "#load \"%s\";;", fname);
-                                        AddLineToControl(buf);
-                                }
-                                free(buf);
-                        }
-                        free(fname);
-                        break;
-                case IDM_GC:
-                        AddLineToControl("Gc.full_major();;");
-                        break;
-                case IDCTRLC:
-                        InterruptOcaml();
-                        break;
-                case IDM_EDITPASTE:
-                        Add_Clipboard_To_Queue();
-                        break;
-                case IDM_EDITCOPY:
-                        CopyToClipboard(hwnd);
-                        break;
-
-				// updated to save a transcript
-                case IDM_SAVEAS:
-                        fname = SafeMalloc(512);
-                        if (GetSaveName(fname,512)) {
-                                SaveText(fname);
-                        }
-                        free(fname);
-                        break;
-
-				// updated to save an ML file
-				case IDM_SAVE:
-                        fname = SafeMalloc(512);
-                        if (GetSaveMLName(fname,512))
-						{
-                                SaveML(fname);
-                        }
-                        free(fname);
-                        break;
-
-				// updated to work with new history system
-                case IDM_HISTORY:
-                        r = CallDlgProc(HistoryDlgProc,IDD_HISTORY);
-
-                        if (r)
-						{
-                                AddLineToControl(GetHistoryLine(r-1));
-                        }
-                        break;
-
-                case IDM_PRINTSU:
-						// Removed by Chris Watford
-						// seems to die
-                        // CallPrintSetup();
-                        break;
-
-                case IDM_FONT:
-                        CallChangeFont(hwndMain);
-                        break;
-                case IDM_COLORTEXT:
-                        ProgramParams.TextColor = CallChangeColor(ProgramParams.TextColor);
-                        ForceRepaint();
-                        break;
-                case IDM_BACKCOLOR:
-                        BackColor = CallChangeColor(BackColor);
-                        DeleteObject(BackgroundBrush);
-                        BackgroundBrush = CreateSolidBrush(BackColor);
-                        ForceRepaint();
-                        break;
-                case IDM_EDITUNDO:
-                        Undo(hwnd);
-                        break;
-
-				/* Removed, really not very useful in this IDE
-                case IDM_WINDOWTILE:
-                        SendMessage(hwndMDIClient,WM_MDITILE,0,0);
-                        break;
-                case IDM_WINDOWCASCADE:
-                        SendMessage(hwndMDIClient,WM_MDICASCADE,0,0);
-                        break;
-                case IDM_WINDOWICONS:
-                        SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0);
-                        break;
-				*/
-
-                case IDM_EXIT:
-                        PostMessage(hwnd,WM_CLOSE,0,0);
-                        break;
-                case IDM_ABOUT:
-                        CallDlgProc(AboutDlgProc,IDD_ABOUT);
-                        break;
-                default:
-                        if (LOWORD(wParam) >= IDEDITCONTROL && LOWORD(wParam) < IDEDITCONTROL+5) {
-                                switch (HIWORD(wParam)) {
-                                        case EN_ERRSPACE:
-                                                ResetText();
-                                                break;
-                                }
-                        }
-                        break;
-        }
-}
diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c
deleted file mode 100644
index 2a2e04a5..00000000
--- a/win32caml/ocaml.c
+++ /dev/null
@@ -1,1599 +0,0 @@
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-/* $Id$ */
-
-/*@@ Wedit generated application. Written Sat Jun 02 18:22:38 2001
-@@header: D:\lcc\inria\inriares.h
-@@resources: D:\lcc\inria\inria.rc
-Do not edit outside the indicated areas */
-/*<---------------------------------------------------------------------->*/
-
-#include 
-#include 
-#include 
-#include 
-#include 
-#include 
-#include 
-#include "inriares.h"
-#include "inria.h"
-
-#define VK_BACKSPACE    0x108
-
-/*<---------------------------------------------------------------------->*/
-int EditControls = IDEDITCONTROL;
-static WNDPROC lpEProc;
-static char lineBuffer[1024*32];
-int ReadToLineBuffer(void);
-int AddLineBuffer(void);
-static int busy;
-static DWORD TimerId;
-POSITION LastPromptPosition;
-char LibDir[512];
-char OcamlPath[512];
-HBRUSH BackgroundBrush;
-COLORREF BackColor = RGB(255,255,255);
-PROGRAM_PARAMS ProgramParams;
-StatementHistory *History = NULL;
-StatementHistory *HistoryTail = NULL;
-StatementHistory *historyEntry = NULL;
-EditBuffer *CurrentEditBuffer = NULL; // current edit buffer
-
-/*<----------------- global variables --------------------------------------->*/
-HANDLE hInst;           // Instance handle
-HWND hwndMain;          //Main window handle
-HWND hwndSession;
-HWND hwndMDIClient;             //Mdi client window handle
-static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam);
-static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam);
-PROCESS_INFORMATION pi;
-HWND  hWndStatusbar;
-
-/*------------------------------------------------------------------------
-Procedure:     UpdateStatusBar ID:1
-Purpose:       Updates the statusbar control with the appropiate
-text
-Input:         lpszStatusString: Charactar string that will be shown
-partNumber: index of the status bar part number.
-displayFlags: Decoration flags
-Output:        none
-Errors:        none
-
-------------------------------------------------------------------------*/
-void UpdateStatusBar(LPSTR lpszStatusString, WORD partNumber, WORD displayFlags)
-{
-	SendMessage(hWndStatusbar,
-		SB_SETTEXT,
-		partNumber | displayFlags,
-		(LPARAM)lpszStatusString);
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     MsgMenuSelect ID:1
-Purpose:       Shows in the status bar a descriptive explaation of
-the purpose of each menu item.The message
-WM_MENUSELECT is sent when the user starts browsing
-the menu for each menu item where the mouse passes.
-Input:         Standard windows.
-Output:        The string from the resources string table is shown
-Errors:        If the string is not found nothing will be shown.
-------------------------------------------------------------------------*/
-LRESULT MsgMenuSelect(HWND hwnd, UINT uMessage, WPARAM wparam, LPARAM lparam)
-{
-	static char szBuffer[256];
-	UINT   nStringID = 0;
-	UINT   fuFlags = GET_WM_MENUSELECT_FLAGS(wparam, lparam) & 0xffff;
-	UINT   uCmd    = GET_WM_MENUSELECT_CMD(wparam, lparam);
-	HMENU  hMenu   = GET_WM_MENUSELECT_HMENU(wparam, lparam);
-
-	szBuffer[0] = 0;                            // First reset the buffer
-	if (fuFlags == 0xffff && hMenu == NULL)     // Menu has been closed
-		nStringID = 0;
-
-	else if (fuFlags & MFT_SEPARATOR)           // Ignore separators
-		nStringID = 0;
-
-	else if (fuFlags & MF_POPUP)                // Popup menu
-	{
-		if (fuFlags & MF_SYSMENU)               // System menu
-			nStringID = IDS_SYSMENU;
-		else
-			// Get string ID for popup menu from idPopup array.
-			nStringID = 0;
-	}  // for MF_POPUP
-	else                                        // Must be a command item
-		nStringID = uCmd;                       // String ID == Command ID
-
-	// Load the string if we have an ID
-	if (0 != nStringID)
-		LoadString(hInst, nStringID, szBuffer, sizeof(szBuffer));
-	// Finally... send the string to the status bar
-	UpdateStatusBar(szBuffer, 0, 0);
-	return 0;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     TimerProc ID:1
-Purpose:       This procedure will be called by windows about 4
-times a second. It will just send a message to the
-mdi child window to look at the pipe.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static VOID CALLBACK TimerProc(HWND hwnd, UINT uMsg, UINT idEvent, DWORD dwTime)
-{
-	SendMessage(hwndSession, WM_TIMERTICK, 0, 0);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     InitializeStatusBar ID:1
-Purpose:       Initialize the status bar
-Input:         hwndParent: the parent window
-nrOfParts: The status bar can contain more than one
-part. What is difficult, is to figure out how this
-should be drawn. So, for the time being only one is
-being used...
-Output:        The status bar is created
-Errors:
-------------------------------------------------------------------------*/
-void InitializeStatusBar(HWND hwndParent,int nrOfParts)
-{
-	const int cSpaceInBetween = 8;
-	int   ptArray[40];   // Array defining the number of parts/sections
-	RECT  rect;
-	HDC   hDC;
-
-	/* * Fill in the ptArray...  */
-
-	hDC = GetDC(hwndParent);
-	GetClientRect(hwndParent, &rect);
-
-	ptArray[nrOfParts-1] = rect.right;
-	//---TODO--- Add code to calculate the size of each part of the status
-	// bar here.
-
-	ReleaseDC(hwndParent, hDC);
-	SendMessage(hWndStatusbar,
-		SB_SETPARTS,
-		nrOfParts,
-		(LPARAM)(LPINT)ptArray);
-
-	UpdateStatusBar("Ready", 0, 0);
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     CreateSBar ID:1
-Purpose:       Calls CreateStatusWindow to create the status bar
-Input:         hwndParent: the parent window
-initial text: the initial contents of the status bar
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static BOOL CreateSBar(HWND hwndParent,char *initialText,int nrOfParts)
-{
-	hWndStatusbar = CreateStatusWindow(WS_CHILD | WS_VISIBLE | WS_BORDER|SBARS_SIZEGRIP,
-		initialText,
-		hwndParent,
-		IDM_STATUSBAR);
-	if(hWndStatusbar)
-	{
-		InitializeStatusBar(hwndParent,nrOfParts);
-		return TRUE;
-	}
-
-	return FALSE;
-}
-/*------------------------------------------------------------------------
-Procedure:     InitApplication ID:1
-Purpose:       Registers two window classes: the "inria" window
-class with the main window, and the mdi child
-window's window class.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static BOOL InitApplication(void)
-{
-	WNDCLASS wc;
-
-	memset(&wc,0,sizeof(WNDCLASS));
-	wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ;
-	wc.lpfnWndProc = (WNDPROC)MainWndProc;
-	wc.hInstance = hInst;
-	wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
-	wc.lpszClassName = "inriaWndClass";
-	wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU);
-	wc.hCursor = LoadCursor(NULL,IDC_ARROW);
-	wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON));
-	if (!RegisterClass(&wc))
-		return 0;
-	wc.style         = 0;
-	wc.lpfnWndProc   = (WNDPROC)MdiChildWndProc;
-	wc.cbClsExtra    = 0;
-	wc.cbWndExtra    = 20;
-	wc.hInstance     = hInst;                      // Owner of this class
-	wc.hIcon         = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON));
-	wc.hCursor       = LoadCursor(NULL, IDC_ARROW);
-	wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color
-	wc.lpszMenuName  = NULL;
-	wc.lpszClassName = "MdiChildWndClass";
-	if (!RegisterClass((LPWNDCLASS)&wc))
-		return FALSE;
-	return 1;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     CreateinriaWndClassWnd ID:1
-Purpose:       Creates the main window
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-HWND CreateinriaWndClassWnd(void)
-{
-	return CreateWindow("inriaWndClass","OCamlWinPlus v1.9RC4",
-		WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME,
-		CW_USEDEFAULT,0,CW_USEDEFAULT,0,
-		NULL,
-		NULL,
-		hInst,
-		NULL);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     MDICmdFileNew ID:1
-Purpose:       Creates a new session window. Note that multiple
-windows with multiple sessions are possible.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static HWND MDICmdFileNew(char *title, int show)
-{
-	HWND  hwndChild;
-	char  rgch[150];
-	static int cUntitled;
-	MDICREATESTRUCT mcs;
-
-	if (title == NULL)
-		wsprintf(rgch,"Session%d", cUntitled++);
-	else {
-		strncpy(rgch,title,149);
-		rgch[149] = 0;
-	}
-
-	// Create the MDI child window
-
-	mcs.szClass = "MdiChildWndClass";      // window class name
-	mcs.szTitle = rgch;             // window title
-	mcs.hOwner  = hInst;            // owner
-	mcs.x       = CW_USEDEFAULT;    // x position
-	mcs.y       = CW_USEDEFAULT;    // y position
-	mcs.cx      = CW_USEDEFAULT;    // width
-	mcs.cy      = CW_USEDEFAULT;    // height
-	mcs.style   = 0;                // window style
-	mcs.lParam  = 0;                // lparam
-
-	hwndChild = (HWND) SendMessage(hwndMDIClient,
-		WM_MDICREATE,
-		0,
-		(LPARAM)(LPMDICREATESTRUCT) &mcs);
-
-	if (hwndChild != NULL && show)
-		ShowWindow(hwndChild, SW_SHOW);
-
-	return hwndChild;
-}
-static HWND CreateMdiClient(HWND hwndparent)
-{
-	CLIENTCREATESTRUCT ccs = {0};
-	HWND hwndMDIClient;
-	int icount = GetMenuItemCount(GetMenu(hwndparent));
-
-	// Find window menu where children will be listed
-	ccs.hWindowMenu  = GetSubMenu(GetMenu(hwndparent), icount-2);
-	ccs.idFirstChild = IDM_WINDOWCHILD;
-
-	// Create the MDI client filling the client area
-	hwndMDIClient = CreateWindow("mdiclient",
-		NULL,
-		WS_CHILD | WS_CLIPCHILDREN | WS_VSCROLL |
-		WS_HSCROLL,
-		0, 0, 0, 0,
-		hwndparent,
-		(HMENU)0xCAC,
-		hInst,
-		(LPVOID)&ccs);
-
-	ShowWindow(hwndMDIClient, SW_SHOW);
-
-	return hwndMDIClient;
-}
-
-void GotoEOF(void)
-{
-	HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-	int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-	int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0);
-	int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0);
-
-	lineindex += lastLineLength;
-	SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GotoPrompt ID:1
-Author:		   Chris Watford watford@uiuc.edu
-Purpose:       Puts the cursor on the prompt line right after the '# '
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void GotoPrompt(void)
-{
-	HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-	int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0)+2;
-	SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
-}
-
-int GetCurLineIndex(HWND hEdit)
-{
-	return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
-}
-
-int GetNumberOfLines(HWND hEdit)
-{
-	return SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-}
-
-static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len)
-{
-	char *line,*p,*pstart,*pend;
-	int lineidx,start,end,length,offset,cursorpos,startingChar;
-
-	SendMessage(hwndEditControl,EM_GETSEL,(WPARAM)&start,(LPARAM)&end);
-	lineidx = SendMessage(hwndEditControl,EM_EXLINEFROMCHAR,0,start);
-	startingChar = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
-	start -= startingChar;
-	end -= startingChar;
-	lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0);
-	length = SendMessage(hwndEditControl,EM_LINELENGTH,lineidx,0);
-	offset = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
-	line = SafeMalloc(length+1);
-	memset(line,0,length+1);
-	*(unsigned short *)line = length;
-	SendMessage(hwndEditControl,EM_GETLINE,lineidx,(LPARAM)line);
-	cursorpos = start-offset;
-	p = line + cursorpos;
-	pstart = p;
-	while (*pstart
-		&& *pstart != ' '
-		&& *pstart != '\t'
-		&& *pstart != '('
-		&& pstart > line)
-		pstart--;
-	pend = p;
-	while (*pend
-		&& *pend != ' '
-		&& *pend != '\t'
-		&& *pend != '('
-		&& pend < line + length)
-		pend++;
-	if (*pstart == ' ' || *pstart == '\t')
-		pstart++;
-	if (*pend == ' ' || *pend == '\t')
-		pend--;
-	memcpy(buf,pstart,1+pend-pstart);
-	buf[pend-pstart] = 0;
-	free(line);
-	return 1;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GetLastLine ID:1
-Purpose:       Gets the data in the line containing the cursor to
-			   the interpreter.
-Input:         The edit control window handle
-Output:        None explicit
-Errors:        None
-------------------------------------------------------------------------*/
-char* GetLastLine(HWND hEdit)
-{
-	int curline = GetCurLineIndex(hEdit);
-	char *linebuffer = (char*)SafeMalloc(2048*sizeof(char));
-	int n;
-	int linescount = GetNumberOfLines(hEdit);
-
-	*(unsigned short *)linebuffer = 2047;
-	n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
-
-	if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
-		n -= 2;
-		memmove(linebuffer, linebuffer+2, n);
-	}
-
-	linebuffer[n] = '\0';
-
-	return linebuffer;
-}
-
-void DoHelp(HWND hwnd)
-{
-	char word[256];
-	GetWordUnderCursor(hwnd,word,sizeof(word));
-	MessageBox(NULL,word,"Aide pour:",MB_OK);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     RewriteCurrentEditBuffer ID:1
-Purpose:       Rewrites what is at the prompt with the current contents of
-			   the edit buffer
-Input:         None
-Output:        None explicit
-Errors:        None
-------------------------------------------------------------------------*/
-void RewriteCurrentEditBuffer(void)
-{
-	// get the editbox's handle
-	HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-
-	// calculate what to highlight
-	int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-	int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0) + 2;
-	int lastLine = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0) + SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0) + 100;
-
-	// delete the current text
-	SendMessage(hEdit, EM_SETSEL, (WPARAM)lineindex, (LPARAM)lastLine);
-	SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)"");
-
-	{
-		// loop through each line in the edit buffer and add it to the control
-		LineList* line = CurrentEditBuffer->Lines;
-		for(; line != NULL; line = line->Next)
-		{
-			// if there is a line before me, add a newline
-			if(line->Prev != NULL)
-				SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)"\r\n");
-
-			// add the line
-			SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)line->Text);
-		}
-	}
-}
-
-/*------------------------------------------------------------------------
-Procedure:     RefreshCurrentEditBuffer ID:1
-Purpose:       Rewrites what is in the CurrentEditBuffer with what is
-			   actually there
-Input:         None
-Output:        None explicit
-Errors:        None
-------------------------------------------------------------------------*/
-void RefreshCurrentEditBuffer(void)
-{
-	// get the editbox's handle
-	HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-
-	// get the last line index
-	int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0) - 1;
-	int i = 0, n = 0;
-
-	// where to hold the line we grab
-	char *linebuffer = (char*)SafeMalloc(2048*sizeof(char));
-	*(unsigned short *)linebuffer = 2047;
-
-	editbuffer_destroy(CurrentEditBuffer);
-	CurrentEditBuffer = editbuffer_new();
-
-	// loop through each line updating or adding it to the current edit buffer
-	for( ; (i + LastPromptPosition.line) <= linesCount; i++)
-	{
-		n = SendMessage(hEdit, EM_GETLINE, (i + LastPromptPosition.line), (LPARAM)linebuffer);
-
-		if ((n >= 2) && (linebuffer[0] == '#') && (linebuffer[1] == ' ')) {
-			n -= 2;
-			memmove(linebuffer, linebuffer+2, n);
-		}
-
-		linebuffer[n] = '\0';
-
-		{	// remove line breaks and feeds
-			char* ln = linebuffer;
-
-			while((*ln) != 0)
-			{
-				switch((*ln))
-				{
-					case '\r':
-					case '\n':
-						(*ln) = ' ';
-				}
-
-				ln++;
-			}
-		}
-
-		editbuffer_addline(CurrentEditBuffer, linebuffer);
-	}
-}
-
-/*------------------------------------------------------------------------
-Procedure:     NextHistoryEntry ID:1
-Purpose:       Scrolls to the next history entry
-Input:         None
-Output:        None explicit
-Errors:        None
---------------------------------------------------------------------------
-Edit History:
-	17 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added this as a helper function
-	18 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Corrected doubly linked list problems
-------------------------------------------------------------------------*/
-void NextHistoryEntry(void)
-{
-	// out of bounds, put it back into bounds
-	if(historyEntry == NULL && History == NULL)
-	{
-		return;
-	} else if (historyEntry == NULL && History != NULL) {
-		historyEntry = History;
-	} else {
-		if(historyEntry->Next == NULL)
-			return;
-
-		historyEntry = historyEntry->Next;
-	}
-
-	// if its valid
-	if(historyEntry != NULL)
-	{
-		// copy the history entry to a new buffer
-		EditBuffer* newBuf = editbuffer_copy(historyEntry->Statement);
-
-		// destroy the old buffer
-		editbuffer_destroy(CurrentEditBuffer);
-
-		// setup the current one to the copy
-		CurrentEditBuffer = newBuf;
-
-		// rewrite the old one and go to the prompt
-		RewriteCurrentEditBuffer();
-		GotoPrompt();
-	}
-}
-
-/*------------------------------------------------------------------------
-Procedure:     PrevHistoryEntry ID:1
-Purpose:       Scrolls to the previous history entry
-Input:         None
-Output:        None explicit
-Errors:        None
---------------------------------------------------------------------------
-Edit History:
-	17 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added this as a helper function
-	18 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Corrected doubly linked list problems
-------------------------------------------------------------------------*/
-void PrevHistoryEntry(void)
-{
-	// out of bounds, put it back into bounds
-	if(historyEntry == NULL || History == NULL)
-	{
-		return;
-	} else {
-		if(historyEntry->Prev == NULL)
-			return;
-
-		historyEntry = historyEntry->Prev;
-	}
-
-	// if its valid
-	if(historyEntry != NULL)
-	{
-		// copy the history entry to a new buffer
-		EditBuffer* newBuf = editbuffer_copy(historyEntry->Statement);
-
-		// destroy the old buffer
-		editbuffer_destroy(CurrentEditBuffer);
-
-		// setup the current one to the copy
-		CurrentEditBuffer = newBuf;
-
-		// rewrite the old one and go to the prompt
-		RewriteCurrentEditBuffer();
-		GotoPrompt();
-	}
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SubClassEdit ID:1
-Purpose:       Handles messages to the editbox
-Input:         
-Output:        
-Errors:
---------------------------------------------------------------------------
-Edit History:
-	14 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Setup handler for up and down arrows
-	15 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Setup framework for history on up arrow
-		- Saves lines you move off of in the edit buffer
-	16 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Proper handling of newline message finished
-		- Fixed ENTER on middle of interior line, moves cursor to the end
-		  and sends the line
-		- Setup the copying and destroying of the old buffer
-		- Included buffer rewrite
-	17 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added C-p/C-n support
-		- Changed UpArrow to C-UpArrow so as to not confuse users
-	18 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added Left and Right arrow line saving
-		- Added backspace and delete line saving and removing
-		- Fixed history scrolling
-	21 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Fixed pasting errors associated with lines being out of bounds
-		  for the buffer
-		- Added error handling, possibly able to handle it diff down the
-		  line
-		- Removed C-Up/C-Dn for history scrolling, buggy at best on my
-		  machine
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK SubClassEdit(HWND hwnd, UINT msg, WPARAM mp1, LPARAM mp2)
-{
-	LRESULT r;
-	int postit=0,nl;
-
-	if (msg == WM_CHAR && mp1 == '\r') {
-		if (!busy) {
-			r =  GetCurLineIndex(hwnd);
-			nl = GetNumberOfLines(hwnd);
-
-			// if we're not the last line
-			if (r != nl-1)
-			{
-				// update or add us, we might not have any lines in the edit buffer
-				editbuffer_updateoraddline(CurrentEditBuffer, r-LastPromptPosition.line, GetLastLine(hwnd));
-
-				// scroll to the end, add CrLf then post the newline message
-				GotoEOF();
-				AddStringToControl("\r\n");
-				PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
-				return 0;
-			}
-
-			CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-			CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-
-			postit = 1;
-		}
-
-	}
-	else if (msg == WM_CHAR && mp1 == (char)0x08) {
-		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-		int nextline = 0;
-		int curpoint = 0;
-
-		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint - 1),0);
-
-		if(curpoint <= lineindex)
-		{
-			return 0;
-		} else if(nextline != curline) {
-			// delete the line we're on
-
-			// grab the index
-			curline -= LastPromptPosition.line;
-
-			// kill it
-			editbuffer_removeline(CurrentEditBuffer, curline);
-		}
-	}
-	else if (msg == WM_KEYDOWN && mp1 == VK_F1) {
-		DoHelp(hwnd);
-	}
-	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && mp1 == VK_UP) {
-		int curline = GetCurLineIndex(hwnd);
-
-		/*if((msg == WM_KEYDOWN) && (GetKeyState(VK_CONTROL) && 0x8000))
-		{	// go forward once in history
-			NextHistoryEntry();
-			return 0;
-		} else */
-		if((curline > LastPromptPosition.line) && (curline <= (LastPromptPosition.line + CurrentEditBuffer->LineCount)))
-		{
-			// update current line
-			if (msg == WM_KEYDOWN)
-			{
-				int lineidx = (curline - LastPromptPosition.line);
-
-				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-				
-				// we may have to add this line, otherwise update it
-				editbuffer_updateoraddline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-			}
-		} else {
-			return 0;
-		}
-	}
-	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_LEFT)) {
-		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-		int nextline = 0;
-		int curpoint = 0;
-
-		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint - 1),0);
-
-		if(curpoint <= lineindex)
-		{	// no left arrow to the left of the prompt
-			return 0;
-		} else if(nextline != curline) {
-			// update current line
-			if (msg == WM_KEYDOWN)
-			{
-				int lineidx = (curline - LastPromptPosition.line);
-
-				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-				
-				// we may have to add this line, otherwise update it
-				editbuffer_updateoraddline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-
-				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_HOME,1);
-				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_HOME,1);
-			}
-		}
-	}
-	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_DOWN)) {
-		int curline = GetCurLineIndex(hwnd);
-		
-		/*if((msg == WM_KEYDOWN) && (GetKeyState(VK_CONTROL) && 0x8000))
-		{	// go back once in history
-			PrevHistoryEntry();
-			return 0;
-		} else*/
-		if((curline >= LastPromptPosition.line) && (curline < (LastPromptPosition.line + CurrentEditBuffer->LineCount)))
-		{
-			// We don't post the newline, but instead update the current line
-			if (msg == WM_KEYDOWN)
-			{
-				int lineidx = (curline - LastPromptPosition.line);
-
-				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-				
-				editbuffer_updateline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-			}
-		} else {
-			return 0;
-		}
-	}
-	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_RIGHT)) {
-		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 1;
-		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-		int nextline = 0;
-		int curpoint = 0;
-
-		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint + 2),0);
-
-		if(curpoint <= lineindex)
-		{	// no movement behind the prompt
-			return 0;
-		} else if((nextline != curline) && (msg = WM_KEYDOWN)) {
-			int lineidx = (curline - LastPromptPosition.line);
-
-			CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-			CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-			
-			editbuffer_updateline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-		}
-	}
-	else if ((msg == WM_KEYDOWN) && (mp1 == VK_PRIOR) && (GetKeyState(VK_CONTROL) && 0x8000)) {
-		// C-p
-		NextHistoryEntry();
-		return 0;
-	}
-	else if ((msg == WM_KEYDOWN) && (mp1 == VK_NEXT) && (GetKeyState(VK_CONTROL) && 0x8000)) {
-		// C-n
-		PrevHistoryEntry();
-		return 0;
-	}
-	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_DELETE)) {
-		// see if we're the last char on the line, if so delete the next line
-		// don't allow deleting left of the prompt
-		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-		int nextline = 0;
-		int curpoint = 0;
-
-		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint + 2),0);
-
-		if(curpoint < lineindex)
-		{	// no chomping behind the prompt
-			return 0;
-		} else if(nextline != curline) {
-			// deleting
-			// grab the next line index
-			curline -= LastPromptPosition.line;
-
-			// kill it
-			editbuffer_removeline(CurrentEditBuffer, curline+1);
-		}
-	}
-	else if (msg == WM_PASTE) {
-		// if they paste text, allow it
-		r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
-
-		// update the current edit buffer
-		RefreshCurrentEditBuffer();
-
-		return r;
-	}
-
-	// handle errors
-	switch(msg)
-	{
-		case WM_SYNTAXERROR:
-		case WM_ILLEGALCHAR:
-		case WM_UNBOUNDVAL:
-			{	// currently I handle them all the same
-				// get the start of the line
-				int start = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-
-				// get the statement that error'd
-				NextHistoryEntry();
-
-				// tell the history that the last line errored
-				if(History != NULL)
-					if(History->Statement != NULL)
-						History->Statement->isCorrect = FALSE;
-
-				// highlight the offending chars
-				SendMessage(hwnd,EM_SETSEL,(WPARAM)(start + mp1), (LPARAM)(start + mp2));
-				
-				return 0;
-			}
-	}
-
-	r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
-
-	if (postit)
-		PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
-
-	return r;
-}
-
-static void SubClassEditField(HWND hwnd)
-{
-	if (lpEProc == NULL) {
-		lpEProc = (WNDPROC) GetWindowLongPtr(hwnd, GWLP_WNDPROC);
-	}
-	SetWindowLongPtr(hwnd, GWLP_WNDPROC, (LONG_PTR) SubClassEdit);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SendLastLine ID:1
-Purpose:       Sends the data in the line containing the cursor to
-the interpreter. If this is NOT the last line, copy
-the line to the end of the text.
-Input:         The edit control window handle
-Output:        None explicit
-Errors:        None
-
-REMOVED!
-------------------------------------------------------------------------*/
-void SendLastLine(HWND hEdit)
-{
-/*	int curline = GetCurLineIndex(hEdit);
-	char *p,linebuffer[2048];
-	int n;
-	int linescount = GetNumberOfLines(hEdit);
-
-	*(unsigned short *)linebuffer = sizeof(linebuffer)-1;
-	if (curline != linescount-1)
-		n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
-	else
-		n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer);
-	if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
-		n -= 2;
-		memmove(linebuffer, linebuffer+2, n);
-	}
-	linebuffer[n] = 0;
-
-	// Record user input!
-	AddToHistory(linebuffer);
-	linebuffer[n] = '\n';
-	linebuffer[n+1] = 0;
-	WriteToPipe(linebuffer);
-	if (curline != linescount-1) {
-		// Copy the line sent to the end of the text
-		p = strrchr(linebuffer,'\n');
-		if (p) {
-			*p = 0;
-		}
-		busy = 1;
-		AddLineToControl(linebuffer);
-		busy = 0;
-	}*/
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SendLastEditBuffer ID:1
-Author:		   Chris Watford watford@uiuc.edu
-Purpose:       Sends an edit buffer to the pipe
-Input:
-Output:
-Errors:
---------------------------------------------------------------------------
-Edit History:
-     7 Aug  2004 - Chris Watford christopher.watford@gmail.com
-		- Fixed error where SendLastEditBuffer sent waaaay too many
-		newlines which completely broke the underlying connection to the
-		ocaml.exe pipe
-	15 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Sends line to the pipe and adds newline to the end
-------------------------------------------------------------------------*/
-void SendLastEditBuffer(HWND hwndChild)
-{
-	char* line = editbuffer_getasbuffer(CurrentEditBuffer);
-	int l = strlen(line) - 1;
-	char* linebuffer = (char*)SafeMalloc(l+2);
-
-	// save current edit buffer to history and create a new blank edit buffer
-	CurrentEditBuffer->isCorrect = TRUE;
-	AddToHistory(CurrentEditBuffer);
-	CurrentEditBuffer = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-	CurrentEditBuffer->LineCount = 0;
-	CurrentEditBuffer->Lines = NULL;
-
-	// trim and add the newline to the end
-	strncpy(linebuffer, line, l+1);
-	while((linebuffer[l] == '\n' || linebuffer[l] == '\r') && (l >= 0))
-	{
-		linebuffer[l--] = '\0';
-	}
-
-	linebuffer[l+1] = '\n';
-	linebuffer[l+2] = '\0';
-
-	// save line to the pipe
-	WriteToPipe(linebuffer);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SendingFullCommand ID:1
-Author:		   Chris Watford watford@uiuc.edu
-Purpose:       Returns if the command being sent 
-Input:         The edit control window handle
-Output:        None explicit
-Errors:        None
---------------------------------------------------------------------------
-Edit History:
-	 7 Aug  2004 - Chris Watford christopher.watford@gmail.com
-		- Fixed bug #2932 where many carraige returns were sent and it came
-		back with a null pointer error due to a fault of not checking if
-		the line returned was NULL
-	13 Oct  2003 - Chris Watford watford@uiuc.edu
-		- Solved the error when you have a malformed comment in the buffer
-------------------------------------------------------------------------*/
-BOOL SendingFullCommand(void)
-{
-	// if there is a ;; on the line, return true
-	char *line = editbuffer_getasline(CurrentEditBuffer);
-	char *firstComment, *firstSemiColonSemiColon, *firstQuote;
-
-	if(line == NULL)
-	{
-		return FALSE;
-	}
-
-	firstComment = strstr(line, "(*");
-	firstSemiColonSemiColon = strstr(line, ";;");
-	firstQuote = strstr(line, "\"");
-
-	// easy case :D
-	if(firstSemiColonSemiColon == NULL)
-	{
-		free(line);
-		return FALSE;
-	}
-
-	// if there are no comments
-	if(firstComment == NULL)
-	{
-		// if there are no quotations used
-		if(firstQuote == NULL)
-		{
-			BOOL r = (firstSemiColonSemiColon != NULL);
-			free(line);
-			return r;
-		} else {
-			// we need to first check if the ;; is before the \", since the \"
-			// won't matter if its before the semicolonsemicolon
-			if(firstQuote < firstSemiColonSemiColon)
-			{
-				// the quote is before the ;;, we need to make sure its terminated
-				// also we have to check for escaped quotes, le sigh!
-				char *c = firstQuote+1;
-				BOOL in_quote = TRUE;
-				
-				// in-quote determiner loop
-				while(c[0] != '\0')
-				{
-					// are we a backslash?
-					if(c[0] == '\\')
-					{
-						// ignore the next character
-						c++;
-					}
-					else
-					{
-							// are we a quote?
-						if(c[0] == '"')
-						{
-							in_quote = !in_quote;
-						}
-					}
-
-					c++;
-				}
-
-				free(line);
-				return !in_quote;
-			} else {
-				BOOL r = (firstSemiColonSemiColon != NULL);
-				free(line);
-				return r;
-			}
-		}
-	} else {
-		// we have to search through finding all comments
-
-		// a neat little trick we can do is compare the point at which
-		// the ;; is and where the first (* can be found, if the ;; is
-		// before the (* ocaml.exe ignores the comment
-		if((unsigned int)firstSemiColonSemiColon < (unsigned int)firstComment)
-		{
-			free(line);
-			return TRUE;
-		} else {
-			// time to search and find if the endline is inside a comment or not
-			// start at the first comment, and move forward keeping track of the
-			// nesting level, if the nest level is 0, i.e. outside a comment
-			// and we find the ;; return TRUE immediately, otherwise keep searching
-			// if we end with a nest level >0 return FALSE
-
-			char *c = firstComment+2; // firstComment[0] is the '(', firstComment[1] is the '*'
-			int nestLevel = 1; // we have a (*
-
-			// in-comment determiner loop
-			while(c[0] != '\0')
-			{
-				// are we an endline
-				if((c[0] == ';') && (c[1] == ';'))
-				{
-					// if we are NOT in a comment, its a full line
-					if(nestLevel <= 0)
-					{
-						free(line);
-						return TRUE;
-					}
-				}
-
-				// are we in a comment?
-				if((c[0] == '(') && (c[1] == '*'))
-				{
-					nestLevel++;
-
-					// watch out we may go past the end
-					if(c[2] == '\0')
-					{
-						free(line);
-						return FALSE;
-					}
-
-					// c needs to advance past the *, cause (*) is NOT the start/finish of a comment
-					c++;
-				}
-
-				// adjust the nesting down a level
-				if((c[0] == '*') && (c[1] == ')'))
-					nestLevel--;
-
-				// next char
-				c++;
-			}
-
-			// not a full line
-			free(line);
-			return FALSE;
-		}
-	}
-
-	// weird case ;)
-	free(line);
-	return FALSE;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     AppendToEditBuffer ID:1
-Author:		   Chris Watford watford@uiuc.edu
-Purpose:       Add a line to the edit buffer
-Input:		   Handle of the edit control
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void AppendToEditBuffer(HWND hEdit)
-{
-	char *p = NULL, linebuffer[2048];
-	int n = 0;
-	int curline = GetCurLineIndex(hEdit);
-	int linescount = GetNumberOfLines(hEdit);
-
-	// they are passing the size of the buffer as
-	// the first 'short' in the array...
-	*(unsigned short *)linebuffer = sizeof(linebuffer)-1;
-
-	if (curline > (linescount-1))
-	{
-		n = SendMessage(hEdit, EM_GETLINE, curline, (LPARAM)linebuffer);
-	} else {
-		n = SendMessage(hEdit, EM_GETLINE, --curline, (LPARAM)linebuffer);
-	}
-
-	// correct for the prompt line
-	if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ')
-	{
-		n -= 2;
-		memmove(linebuffer, linebuffer+2, n);
-	}
-
-	linebuffer[n] = '\0';
-
-	// linebuffer now has the line to add to our edit buffer
-	editbuffer_updateoraddline(CurrentEditBuffer, (curline - LastPromptPosition.line), linebuffer);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SetLastPrompt ID:1
-Purpose:       Record the position of the last prompt ("# ") sent by
-the interpreter. This isn't really used yet.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void SetLastPrompt(HWND hEdit)
-{
-	DWORD startpos,endpos;
-	SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos);
-	LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
-	LastPromptPosition.col = startpos;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     MdiChildWndProc ID:1
-Purpose:       The edit control is enclosed in a normal MDI window.
-This is the window procedure for that window. When it
-receives the WM_CREATE message, it will create the
-edit control.
-Input:
-Output:
-Errors:
---------------------------------------------------------------------------
-Edit History:
-	14 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added edit buffer and statement buffer support to the WM_NEWLINE
-		  message.
-	15 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Got it adding to the edit buffer
-	16 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Proper handling of newline message finished
-	21 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Added error detection on return from ocaml interp
-	23 Sept 2003 - Chris Watford watford@uiuc.edu
-		- Fixed prompt detection error as pointed out by Patrick Meredith
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM lparam)
-{
-	HWND hwndChild;
-	RECT rc;
-	HDC hDC;
-
-	switch(msg) {
-		case WM_CREATE:
-			GetClientRect(hwnd,&rc);
-			hwndChild= CreateWindow("EDIT",
-				NULL,
-				WS_CHILD | WS_VISIBLE |
-				ES_MULTILINE |
-				WS_VSCROLL | WS_HSCROLL |
-				ES_AUTOHSCROLL | ES_AUTOVSCROLL,
-				0,
-				0,
-				(rc.right-rc.left),
-				(rc.bottom-rc.top),
-				hwnd,
-				(HMENU) EditControls++,
-				hInst,
-				NULL);
-			SetWindowLongPtr(hwnd, DWLP_USER, (LONG_PTR) hwndChild);
-			SendMessage(hwndChild, WM_SETFONT, (WPARAM) ProgramParams.hFont, 0L);
-			SendMessage(hwndChild,EM_LIMITTEXT,0xffffffff,0);
-			SubClassEditField(hwndChild);
-			break;
-			// Resize the edit control
-		case WM_SIZE:
-			hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-			MoveWindow(hwndChild, 0, 0, LOWORD(lparam), HIWORD(lparam), TRUE);
-			break;
-			// Always set the focus to the edit control.
-		case WM_SETFOCUS:
-			hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-			SetFocus(hwndChild);
-			break;
-			// Repainting of the edit control about to happen.
-			// Set the text color and the background color
-		case WM_CTLCOLOREDIT:
-			hDC = (HDC)wparam;
-			SetTextColor(hDC,ProgramParams.TextColor);
-			SetBkColor(hDC,BackColor);
-			return (LRESULT)BackgroundBrush;
-			// Take care of erasing the background color to avoid flicker
-		case WM_ERASEBKGND:
-			GetWindowRect(hwnd,&rc);
-			hDC = (HDC)wparam;
-			FillRect(hDC,&rc,BackgroundBrush);
-			return 1;
-			// A carriage return has been pressed. Send the data to the interpreted.
-			// This message is posted by the subclassed edit field.
-		case WM_COMMAND:
-			if (LOWORD(wparam) >= IDEDITCONTROL && LOWORD(wparam) < IDEDITCONTROL+5) {
-				switch (HIWORD(wparam)) {
-					case EN_ERRSPACE:
-					case EN_MAXTEXT:
-						ResetText();
-						break;
-				}
-			}
-			break;
-		case WM_NEWLINE:
-			if (busy)
-				break;
-
-			hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-
-			// add what they wrote to the edit buffer
-			AppendToEditBuffer(hwndChild);
-
-		/** Modified by Chris Watford 14 Sept 2003, 15 Sept 2003, 16 Sept 2003 **/
-			// test if this line has an end or if it needs to be in the Edit Buffer
-			if(SendingFullCommand())
-			{
-				// send the edit buffer to the interpreter
-				//SendLastLine(hwndChild);
-				SendLastEditBuffer(hwndChild);
-				historyEntry = NULL;
-			} else {
-				AddStringToControl("  ");
-			}
-		/** End Modifications **/
-
-			break;
-			// The timer will call us 4 times a second. Look if the interpreter
-			// has written something in its end of the pipe.
-		case WM_TIMERTICK:
-		/** Modified by Chris Watford 21 Sept 2003 **/
-			hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-
-			if (ReadToLineBuffer())
-			{
-				int errMsg = 0;
-				char *p, *l = lineBuffer;
-
-				// Ok we read something. Display the trimmed version
-				while(((*l) == ' ') || ((*l) == '\t') || ((*l) == '\n') || ((*l) == '\r') || ((*l) == '*'))
-					l++;
-
-				SendMessage(hwndChild,EM_REPLACESEL,0,(LPARAM)l);
-
-				// fix bug where it won't find prompt
-				p = strrchr(l, '\r');
-				if((l[0] == '#') || (p != NULL))
-				{
-					if(p != NULL)
-					{
-						if(!strcmp(p, "\r\n# "))
-						{
-							SetLastPrompt(hwndChild);
-						}
-					// solve the bug Patrick found
-					} else if((l[0] == '#') && (l[1] == ' ')) {
-						SetLastPrompt(hwndChild);
-					}
-				}
-
-				// detect syntax errors
-				if(strstr(lineBuffer, "Syntax error"))
-				{
-					errMsg = WM_SYNTAXERROR;
-				} else if(strstr(lineBuffer, "Illegal character")) {
-					errMsg = WM_ILLEGALCHAR;
-				} else if(strstr(lineBuffer, "Unbound value")) {
-					errMsg = WM_UNBOUNDVAL;
-				}
-
-				// error! error! alert alert!
-				if(errMsg > 0)
-				{
-					int len = strlen(lineBuffer);
-					char* err = (char*)SafeMalloc(len+1);
-					char *m = err, *n1 = NULL, *n2 = NULL, *nt = NULL;
-
-					// make a copy of the message
-					strncpy(err, lineBuffer, len);
-					err[len] = '\0';
-
-					// find it
-					m = strstr(err, "Characters ");
-					if(m == NULL)
-						break;
-
-					// got the start char
-					n1 = m + strlen("Characters ");
-					
-					// start looking for the end char
-					nt = strstr(n1, "-");
-					if(nt == NULL)
-						break;
-					
-					// makes n1 a valid string
-					nt[0] = '\0';
-
-					// end char is right after this
-					n2 = nt + 1;
-
-					// find the end of n2
-					nt = strstr(n2, ":");
-					if(nt == NULL)
-						break;
-
-					// makes n2 a valid string
-					nt[0] = '\0';
-
-					SendMessage(hwndChild, errMsg, (WPARAM)atoi(n1), (LPARAM)atoi(n2));
-				}
-			}
-		/** End Modifications **/
-
-			break;
-
-	}
-	return DefMDIChildProc(hwnd, msg, wparam, lparam);
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     MainWndProc ID:1
-Purpose:       Window procedure for the frame window, that contains
-the menu. The messages handled are:
-WM_CREATE: Creates the mdi child window
-WM_SIZE: resizes the status bar and the mdi child
-window
-WM_COMMAND: Sends the command to the dispatcher
-WM_CLOSE: If the user confirms, it exists the program
-WM_QUITOCAML: Stops the program unconditionally.
-Input:         Standard windows callback
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam)
-{
-	switch (msg) {
-		// Create the MDI client invisible window
-		case WM_CREATE:
-			hwndMDIClient = CreateMdiClient(hwnd);
-			TimerId = SetTimer((HWND) 0, 0, 100, (TIMERPROC) TimerProc);
-			break;
-			// Move the child windows
-		case WM_SIZE:
-			SendMessage(hWndStatusbar,msg,wParam,lParam);
-			InitializeStatusBar(hWndStatusbar,1);
-			// Position the MDI client window between the tool and status bars
-			if (wParam != SIZE_MINIMIZED) {
-				RECT rc, rcClient;
-
-				GetClientRect(hwnd, &rcClient);
-				GetWindowRect(hWndStatusbar, &rc);
-				ScreenToClient(hwnd, (LPPOINT)&rc.left);
-				rcClient.bottom = rc.top;
-				MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE);
-			}
-
-			return 0;
-			// Dispatch the menu commands
-		case WM_COMMAND:
-			HandleCommand(hwnd, wParam,lParam);
-			return 0;
-			// If user confirms close
-		case WM_CLOSE:
-			if (!AskYesOrNo("Quit OCamlWinPlus?"))
-				return 0;
-			break;
-			// End application
-		case WM_DESTROY:
-			PostQuitMessage(0);
-			break;
-			// The interpreter has exited. Force close of the application
-		case WM_QUITOCAML:
-			DestroyWindow(hwnd);
-			return 0;
-		case WM_USER+1000:
-			// TestGraphics();
-			break;
-		default:
-			return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
-	}
-	return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     CreationCourier ID:1
-Purpose:       Creates the courier font
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static HFONT CreationCourier(int flag)
-{
-	LOGFONT CurrentFont;
-	memset(&CurrentFont, 0, sizeof(LOGFONT));
-	CurrentFont.lfCharSet = ANSI_CHARSET;
-	CurrentFont.lfWeight = FW_NORMAL;
-	if (flag)
-		CurrentFont.lfHeight = 18;
-	else
-		CurrentFont.lfHeight = 15;
-	CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
-	strcpy(CurrentFont.lfFaceName, "Courier");  /* Courier */
-	return (CreateFontIndirect(&CurrentFont));
-}
-
-/*------------------------------------------------------------------------
-Procedure:     ReadToLineBuffer ID:1
-Purpose:       Reads into the line buffer the characters written by
-the interpreter
-Input:         None
-Output:        The number of characters read
-Errors:        None
-------------------------------------------------------------------------*/
-int ReadToLineBuffer(void)
-{
-	memset(lineBuffer,0,sizeof(lineBuffer));
-	return ReadFromPipe(lineBuffer,sizeof(lineBuffer));
-}
-
-/*------------------------------------------------------------------------
-Procedure:     AddLineBuffer ID:1
-Purpose:       Sends the contents of the line buffer to the edit
-control
-Input:         None
-Output:
-Errors:
-------------------------------------------------------------------------*/
-int AddLineBuffer(void)
-{
-	HWND hEditCtrl;
-
-	hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-	return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer);
-
-}
-
-/*------------------------------------------------------------------------
-Procedure:     Setup ID:1
-Purpose:       Handles GUI initialization (Fonts, brushes, colors,
-etc)
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static int Setup(HANDLE *phAccelTable)
-{
-	if (!InitApplication())
-		return 0;
-	ProgramParams.hFont = CreationCourier(1);
-	ProgramParams.TextColor = RGB(0,0,0);
-	GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont);
-	BackgroundBrush = CreateSolidBrush(BackColor);
-	*phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL));
-	return 1;
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     WinMain ID:1
-Purpose:       Entry point for windows programs.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, INT nCmdShow)
-{
-	MSG msg;
-	HANDLE hAccelTable;
-	char consoleTitle[512];
-	HWND hwndConsole;
-
-	CurrentEditBuffer = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-	CurrentEditBuffer->LineCount = 0;
-	CurrentEditBuffer->Lines = NULL;
-
-	//setup the history index pointer
-	historyEntry = NULL;
-
-	// Setup the hInst global
-	hInst = hInstance;
-	// Do the setup
-	if (!Setup(&hAccelTable))
-		return 0;
-	// Need to set up a console so that we can send ctrl-break signal
-	// to inferior Caml
-	AllocConsole();
-	GetConsoleTitle(consoleTitle,sizeof(consoleTitle));
-	hwndConsole = FindWindow(NULL,consoleTitle);
-	ShowWindow(hwndConsole,SW_HIDE);
-	// Create main window and exit if this fails
-	if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0)
-		return 0;
-	// Create the status bar
-	CreateSBar(hwndMain,"Ready",2);
-	// Show the window
-	ShowWindow(hwndMain,SW_SHOW);
-	// Create the session window
-	hwndSession = MDICmdFileNew("Session transcript",0);
-	// Get the path to ocaml.exe
-	GetOcamlPath();
-	// Start the interpreter
-	StartOcaml();
-	// Show the session window
-	ShowWindow(hwndSession, SW_SHOW);
-	// Maximize it
-	SendMessage(hwndMDIClient, WM_MDIMAXIMIZE, (WPARAM) hwndSession, 0);
-
-	PostMessage(hwndMain,WM_USER+1000,0,0);
-	while (GetMessage(&msg,NULL,0,0)) {
-		if (!TranslateMDISysAccel(hwndMDIClient, &msg))
-			if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) {
-				TranslateMessage(&msg);  // Translates virtual key codes
-				DispatchMessage(&msg);   // Dispatches message to window
-			}
-	}
-	WriteToPipe("#quit;;\r\n\032");
-	KillTimer((HWND) 0, TimerId);
-	return msg.wParam;
-}
diff --git a/win32caml/ocaml.ico b/win32caml/ocaml.ico
deleted file mode 100644
index 13560db4..00000000
Binary files a/win32caml/ocaml.ico and /dev/null differ
diff --git a/win32caml/ocaml.rc b/win32caml/ocaml.rc
deleted file mode 100644
index 52ae9497..00000000
--- a/win32caml/ocaml.rc
+++ /dev/null
@@ -1,255 +0,0 @@
-// Microsoft Visual C++ generated resource script.
-//
-#include "resource.h"
-
-#define APSTUDIO_READONLY_SYMBOLS
-/////////////////////////////////////////////////////////////////////////////
-//
-// Generated from the TEXTINCLUDE 2 resource.
-//
-#define APSTUDIO_HIDDEN_SYMBOLS
-#include "windows.h"
-#undef APSTUDIO_HIDDEN_SYMBOLS
-#include "inriares.h"
-
-/////////////////////////////////////////////////////////////////////////////
-#undef APSTUDIO_READONLY_SYMBOLS
-
-/////////////////////////////////////////////////////////////////////////////
-// English (U.S.) resources
-
-#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
-#ifdef _WIN32
-LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
-#pragma code_page(1252)
-#endif //_WIN32
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Icon
-//
-
-// Icon with lowest ID value placed first to ensure application icon
-// remains consistent on all systems.
-1000                    ICON                    "ocaml.ico"
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Menu
-//
-
-IDMAINMENU MENU 
-BEGIN
-    POPUP "&File"
-    BEGIN
-        MENUITEM "&Open...",                    IDM_OPEN
-        MENUITEM "&Save ML...",                 IDM_SAVE
-        MENUITEM "Save &Transcript...",         IDM_SAVEAS
-        MENUITEM SEPARATOR
-        MENUITEM "&Print",                      IDM_PRINT, GRAYED
-        MENUITEM "P&rint Setup...",             IDM_PRINTSU, GRAYED
-        MENUITEM SEPARATOR
-        MENUITEM "E&xit",                       IDM_EXIT
-    END
-    POPUP "&Edit"
-    BEGIN
-        MENUITEM "&Undo\tAlt+BkSp",             IDM_EDITUNDO
-        MENUITEM SEPARATOR
-        MENUITEM "Cu&t\t Shift+Del",            IDM_EDITCUT
-        MENUITEM "&Copy\tCtrl+Ins",             IDM_EDITCOPY
-        MENUITEM "&Paste\tShift+Ins",           IDM_EDITPASTE
-    END
-    POPUP "Workspace"
-    BEGIN
-        MENUITEM "&Font...",                    IDM_FONT
-        MENUITEM "Text &Color...",              IDM_COLORTEXT
-        MENUITEM "&Background Color...",        IDM_BACKCOLOR
-        MENUITEM SEPARATOR
-        MENUITEM "&History...",                 IDM_HISTORY
-        MENUITEM "&Garbage Collect",            IDM_GC
-        MENUITEM "&Interrupt",                  IDCTRLC
-    END
-    POPUP "&Window", GRAYED
-    BEGIN
-        MENUITEM "&Tile",                       IDM_WINDOWTILE, INACTIVE
-        MENUITEM "&Cascade",                    IDM_WINDOWCASCADE, INACTIVE
-        MENUITEM "Arrange &Icons",              IDM_WINDOWICONS, INACTIVE
-        MENUITEM "Close &All",                  IDM_WINDOWCLOSEALL, INACTIVE
-    END
-    POPUP "&Help"
-    BEGIN
-        MENUITEM "&About...",                   IDM_ABOUT
-    END
-END
-
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Accelerator
-//
-
-BARMDI ACCELERATORS 
-BEGIN
-    "Q",            IDM_EXIT,               VIRTKEY, CONTROL
-END
-
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Dialog
-//
-
-IDD_ABOUT DIALOGEX 7, 29, 236, 81
-STYLE DS_SETFONT | DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION | 
-    WS_SYSMENU
-EXSTYLE WS_EX_TOOLWINDOW | WS_EX_CLIENTEDGE
-CAPTION "About OCamlWinPlus"
-FONT 8, "MS Sans Serif", 0, 0, 0x1
-BEGIN
-    LTEXT           "Objective Caml for Windows",101,75,7,90,12
-    LTEXT           "New Windows Interface 1.9RC4",102,68,15,104,12
-    CTEXT           "Copyright 1996-2001\nUpdated 2003",103,88,25,66,23
-    CTEXT           "Institut National de Recherche en Informatique et Automatique",
-                    104,16,46,211,10
-    CTEXT           "Réalisé par Jacob Navia 2001.  Updated by Chris Watford 2003.\nwatford@uiuc.edu",
-                    105,18,54,207,19
-END
-
-IDD_HISTORY DIALOGEX 6, 18, 261, 184
-STYLE DS_SETFONT | DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | 
-    WS_SYSMENU | WS_THICKFRAME
-EXSTYLE WS_EX_TOOLWINDOW
-CAPTION "Session History"
-FONT 8, "MS Sans Serif", 0, 0, 0x1
-BEGIN
-    LISTBOX         IDLIST,7,7,247,173,LBS_USETABSTOPS | WS_VSCROLL | 
-                    WS_HSCROLL | WS_TABSTOP
-END
-
-
-#ifdef APSTUDIO_INVOKED
-/////////////////////////////////////////////////////////////////////////////
-//
-// TEXTINCLUDE
-//
-
-1 TEXTINCLUDE 
-BEGIN
-    "resource.h\0"
-END
-
-2 TEXTINCLUDE 
-BEGIN
-    "#define APSTUDIO_HIDDEN_SYMBOLS\r\n"
-    "#include ""windows.h""\r\n"
-    "#undef APSTUDIO_HIDDEN_SYMBOLS\r\n"
-    "#include ""inriares.h""\r\n"
-    "\0"
-END
-
-3 TEXTINCLUDE 
-BEGIN
-    "\r\n"
-    "\0"
-END
-
-#endif    // APSTUDIO_INVOKED
-
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// String Table
-//
-
-STRINGTABLE 
-BEGIN
-    3010                    "Switches to "
-END
-
-STRINGTABLE 
-BEGIN
-    2000                    "Create, open, save, or print documents"
-    2010                    "Get help"
-END
-
-STRINGTABLE 
-BEGIN
-    500                     "Displays information about this application"
-END
-
-STRINGTABLE 
-BEGIN
-    440                     "Closes all open windows"
-END
-
-STRINGTABLE 
-BEGIN
-    420                     "Arranges windows as overlapping tiles"
-    430                     "Arranges minimized window icons"
-END
-
-STRINGTABLE 
-BEGIN
-    410                     "Arranges windows as non-overlapping tiles"
-END
-
-STRINGTABLE 
-BEGIN
-    340                     "Inserts the clipboard contents at the insertion point"
-    350                     "Removes the selection without putting it on the clipboard"
-END
-
-STRINGTABLE 
-BEGIN
-    320                     "Cuts the selection and puts it on the clipboard"
-    330                     "Copies the selection and puts it on the clipboard"
-END
-
-STRINGTABLE 
-BEGIN
-    310                     "Reverses the last action"
-END
-
-STRINGTABLE 
-BEGIN
-    260                     "Changes the printer selection or configuration"
-    270                     "Quits this application"
-END
-
-STRINGTABLE 
-BEGIN
-    240                     "Closes the active document"
-    250                     "Prints the active document"
-END
-
-STRINGTABLE 
-BEGIN
-    230                     "Saves the active document under a different name"
-END
-
-STRINGTABLE 
-BEGIN
-    210                     "Opens an existing document"
-    220                     "Saves the active document"
-END
-
-STRINGTABLE 
-BEGIN
-    200                     "Creates a new session"
-END
-
-#endif    // English (U.S.) resources
-/////////////////////////////////////////////////////////////////////////////
-
-
-
-#ifndef APSTUDIO_INVOKED
-/////////////////////////////////////////////////////////////////////////////
-//
-// Generated from the TEXTINCLUDE 3 resource.
-//
-
-
-/////////////////////////////////////////////////////////////////////////////
-#endif    // not APSTUDIO_INVOKED
-
diff --git a/win32caml/resource.h b/win32caml/resource.h
deleted file mode 100644
index 67625979..00000000
--- a/win32caml/resource.h
+++ /dev/null
@@ -1,16 +0,0 @@
-//{{NO_DEPENDENCIES}}
-// Microsoft Visual C++ generated include file.
-// Used by ocaml.rc
-//
-
-// Next default values for new objects
-// 
-#ifdef APSTUDIO_INVOKED
-#ifndef APSTUDIO_READONLY_SYMBOLS
-#define _APS_NO_MFC                     1
-#define _APS_NEXT_RESOURCE_VALUE        101
-#define _APS_NEXT_COMMAND_VALUE         40001
-#define _APS_NEXT_CONTROL_VALUE         1000
-#define _APS_NEXT_SYMED_VALUE           101
-#endif
-#endif
diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c
deleted file mode 100644
index f1a3562d..00000000
--- a/win32caml/startocaml.c
+++ /dev/null
@@ -1,362 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  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.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include 
-#include 
-#include 
-#include 
-#include "inria.h"
-
-PROCESS_INFORMATION pi;
-#define BUFSIZE 4096
-STARTUPINFO startInfo;
-
-/*------------------------------------------------------------------------
-Procedure:     ShowDbgMsg ID:1
-Purpose:       Puts up a dialog box with a message, forcing it to
-the foreground.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void ShowDbgMsg(char *str)
-{
-	HWND hWnd;
-	char p[20], message[255];
-	hWnd = hwndMain;
-	if (IsIconic(hWnd)){
-		ShowWindow(hWnd,SW_RESTORE);
-	}
-	strncpy(message, str, 254);
-	message[254] = 0;
-	strcpy(p, "Error");
-	MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND);
-}
-
-int AskYesOrNo(char *msg)
-{
-	HWND hwnd;
-	int r;
-
-	hwnd = hwndMain;
-	r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND);
-	if (r == IDYES)
-		return (TRUE);
-	return (FALSE);
-}
-
-
-static DWORD OcamlStatus;
-
-static int RegistryError(void)
-{
-	char buf[512];
-
-	wsprintf(buf,"Error %d writing to the registry",GetLastError());
-	ShowDbgMsg(buf);
-	return 0;
-}
-
-static int ReadRegistry(HKEY hroot,
-						char * p1, char * p2, char * p3,
-						char dest[1024])
-{
-	HKEY h1, h2;
-	DWORD dwType;
-	unsigned long size;
-	LONG ret;
-
-	if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
-		return 0;
-	if (RegOpenKeyExA(h1, p2, 0, KEY_QUERY_VALUE, &h2) != ERROR_SUCCESS) {
-		RegCloseKey(h1);
-		return 0;
-	}
-	dwType = REG_SZ;
-	size = 1024;
-	ret = RegQueryValueExA(h2, p3, 0, &dwType, dest, &size);
-	RegCloseKey(h2);
-	RegCloseKey(h1);
-	return ret == ERROR_SUCCESS;
-}
-
-static int WriteRegistry(HKEY hroot,
-						 char * p1, char * p2, char * p3,
-						 char data[1024])
-{
-	HKEY h1, h2;
-	DWORD disp;
-	LONG ret;
-
-	if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
-		return 0;
-	if (RegCreateKeyExA(h1, p2, 0, NULL, 0, KEY_ALL_ACCESS, NULL, &h2, &disp)
-		!= ERROR_SUCCESS) {
-			RegCloseKey(h1);
-			return 0;
-		}
-		ret = RegSetValueEx(h2, p3, 0, REG_SZ, data, strlen(data) + 1);
-		RegCloseKey(h2);
-		RegCloseKey(h1);
-		return ret == ERROR_SUCCESS;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GetOcamlPath ID:1
-Purpose:       Read the registry key 
-HKEY_LOCAL_MACHINE\Software\Objective Caml
-or
-HKEY_CURRENT_USER\Software\Objective Caml,
-and creates it if it doesn't exists.
-If any error occurs, i.e. the
-given path doesn't exist, or the key didn't exist, it
-will put up a browse dialog box to allow the user to
-enter the path. The path will be verified that it
-points to a file that exists. If that file is in a
-directory called 'bin', it will look for another
-directory in the same level called lib' and set the
-Lib path to that.
-Input:         None explicit
-Output:        1 means sucess, zero failure
-Errors:        Almost all system calls will be verified
-------------------------------------------------------------------------*/
-int GetOcamlPath(void)
-{
-  char path[1024], *p;
-
-  while (( !ReadRegistry(HKEY_CURRENT_USER,
-			 "Software", "Objective Caml",
-			 "InterpreterPath", path)
-	   &&
-	   !ReadRegistry(HKEY_LOCAL_MACHINE,
-			 "Software", "Objective Caml",
-			 "InterpreterPath", path))
-	 || _access(path, 0) != 0) {
-    /* Registry key doesn't exist or contains invalid path */
-    /* Ask user */
-    if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) {
-      ShowDbgMsg("Impossible to find ocaml.exe. I quit");
-      exit(0);
-    }
-    WriteRegistry(HKEY_CURRENT_USER,
-		  "Software", "Objective Caml",
-		  "InterpreterPath", path);
-    /* Iterate to validate again */
-  }
-  strcpy(OcamlPath, path);
-  p = strrchr(OcamlPath,'\\');
-  if (p) {
-    *p = 0;
-    strcpy(LibDir,OcamlPath);
-    *p = '\\';
-    p = strrchr(LibDir,'\\');
-    if (p && !stricmp(p,"\\bin")) {
-      *p = 0;
-      strcat(LibDir,"\\lib");
-    }
-  }
-  return 1;
-}
-
-static HANDLE hChildStdinRd, hChildStdinWr,hChildStdoutRd, hChildStdoutWr;
-/*------------------------------------------------------------------------
-Procedure:     IsWindowsNT ID:1
-Purpose:       Returns 1 if we are running under windows NT, zero
-otherwise.
-Input:         None
-Output:        1 or zero
-Errors:
-------------------------------------------------------------------------*/
-int IsWindowsNT(void)
-{
-	OSVERSIONINFO osv;
-
-	osv.dwOSVersionInfoSize = sizeof(osv);
-	GetVersionEx(&osv);
-	return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     DoStartOcaml ID:1
-Purpose:       Starts the ocaml interpreter ocaml.exe. The standard
-input of the interpreter will be connected to a pipe,
-and the standard output and standard error to another
-pipe. The interpreter starts as a hidden process,
-showing only in the task list. Since this is in an
-own thread, its workings are independent of the rest
-of the program. After starting the interpreter, the
-thread waits in case the interpreter exits, for
-instance if the user or some program types #quit;;.
-In this case, the waiting thread awakens and exits
-the user interface.
-Input:         Not used. It uses the OcamlPath global variable, that
-is supposed to be correct, no test for its validity
-are done here.
-Output:        None visible
-Errors:        If any system call for whatever reason fails, the
-thread will exit. No error message is shown.
-------------------------------------------------------------------------*/
-DWORD WINAPI DoStartOcaml(LPVOID param)
-{
-        HWND hwndParent = (HWND) param;
-	char *cmdline;
-	int processStarted;
-	LPSECURITY_ATTRIBUTES lpsa=NULL;
-	SECURITY_ATTRIBUTES sa;
-	SECURITY_DESCRIPTOR sd;
-
-	sa.nLength = sizeof(SECURITY_ATTRIBUTES);
-	// Under windows NT/2000/Whistler we have to initialize the security descriptors
-	// This is not necessary under windows 98/95.
-	if (IsWindowsNT()) {
-		InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION);
-		SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE);
-		sa.bInheritHandle = TRUE;
-		sa.lpSecurityDescriptor = &sd;
-		lpsa = &sa;
-	}
-	memset(&startInfo,0,sizeof(STARTUPINFO));
-	startInfo.cb = sizeof(STARTUPINFO);
-	// Create a pipe for the child process's STDOUT.
-	if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0))
-		return 0;
-	// Create a pipe for the child process's STDIN.
-	if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0))
-		return 0;
-	// Setup the start info structure
-	startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW;
-	startInfo.wShowWindow = SW_HIDE;
-	startInfo.hStdOutput = hChildStdoutWr;
-	startInfo.hStdError = hChildStdoutWr;
-	startInfo.hStdInput = hChildStdinRd;
-	cmdline = OcamlPath;
-	// Set the OCAMLLIB environment variable
-	SetEnvironmentVariable("OCAMLLIB", LibDir);
-	// Let's go: start the ocaml interpreter
-	processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1,
-		CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS,
-		NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi);
-	if (processStarted) {
-		WaitForSingleObject(pi.hProcess,INFINITE);
-		GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus);
-		CloseHandle(pi.hProcess);
-		PostMessage(hwndMain,WM_QUITOCAML,0,0);
-	}
-	else {
-		char *msg = malloc(1024);
-		wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline);
-		ShowDbgMsg(msg);
-		free(msg);
-	}
-	return 0;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     WriteToPipe ID:1
-Purpose:       Writes the given character string to the standard
-input of the interpreter
-Input:         The character string (zero terminated) to be written
-Output:        The number of characters written or zero if an error
-occurs
-Errors:        None
-------------------------------------------------------------------------*/
-int WriteToPipe(char *data)
-{
-	DWORD dwWritten;
-
-	if (! WriteFile(hChildStdinWr, data, strlen(data), &dwWritten, NULL))
-		return 0;
-
-	return dwWritten;
-
-}
-
-/*------------------------------------------------------------------------
-Procedure:     ReadFromPipe ID:1
-Purpose:       Reads from the standard output of the interpreter and
-stores the data in the given buffer up to the given
-length. This is done in a non-blocking manner, i.e.
-it is safe to call this even if there is no data
-available.
-Input:         The buffer to be used and its length.
-Output:        Returns the number of characters read from the pipe.
-Errors:        None explicit
-------------------------------------------------------------------------*/
-int ReadFromPipe(char *data,int len)
-{
-	DWORD dwRead;
-
-	PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL);
-	if (dwRead == 0)
-		return 0;
-
-	// Read output from the child process, and write to parent's STDOUT.
-	if( !ReadFile( hChildStdoutRd, data, len, &dwRead, NULL) || dwRead == 0)
-		return 0;
-
-	return dwRead;
-}
-
-static DWORD tid;
-/*------------------------------------------------------------------------
-Procedure:     StartOcaml ID:1
-Purpose:       Starts the thread that will call the ocaml.exe
-program.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-int StartOcaml(void)
-{
-	getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir));
-	CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid);
-	return 1;
-}
-
-
-void *SafeMalloc(int size)
-{
-	void *result;
-
-	if (size < 0) {
-		char message[1024];
-
-error:
-		sprintf(message,"Can't allocate %d bytes",size);
-		MessageBox(NULL, message, "Ocaml", MB_OK);
-		exit(-1);
-	}
-	result = malloc(size);
-
-	if (result == NULL)
-		goto error;
-
-	return result;
-}
-
-
-void InterruptOcaml(void)
-{
-	if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
-		char message[1024];
-		sprintf(message, "GenerateConsole failed: %lu\n", GetLastError());
-		MessageBox(NULL, message, "Ocaml", MB_OK);
-	}
-	WriteToPipe(" ");
-}
diff --git a/yacc/.cvsignore b/yacc/.cvsignore
deleted file mode 100644
index d7fa25cf..00000000
--- a/yacc/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-ocamlyacc
-*.c.x
-ocamlyacc.xcoff
-version.h
-.gdb_history
diff --git a/yacc/.ignore b/yacc/.ignore
new file mode 100644
index 00000000..bf37bf6c
--- /dev/null
+++ b/yacc/.ignore
@@ -0,0 +1,3 @@
+ocamlyacc
+version.h
+.gdb_history
diff --git a/yacc/Makefile b/yacc/Makefile
index a90700f2..fb560cfd 100644
--- a/yacc/Makefile
+++ b/yacc/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
index a33fa014..14a69f02 100644
--- a/yacc/Makefile.nt
+++ b/yacc/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
diff --git a/yacc/closure.c b/yacc/closure.c
index 1b7926a0..b3f4659d 100644
--- a/yacc/closure.c
+++ b/yacc/closure.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/defs.h b/yacc/defs.h
index 1be27d1a..75c8ef10 100644
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/error.c b/yacc/error.c
index ae0b77ac..f0b92d2d 100644
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/lalr.c b/yacc/lalr.c
index f87afb1d..d595e76d 100644
--- a/yacc/lalr.c
+++ b/yacc/lalr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/lr0.c b/yacc/lr0.c
index e05fcb07..3da50da0 100644
--- a/yacc/lr0.c
+++ b/yacc/lr0.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/main.c b/yacc/main.c
index feb2dbda..8616b9b3 100644
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -188,7 +188,7 @@ void getargs(int argc, char **argv)
 
         case 'v':
             if (!strcmp (argv[i], "-version")){
-              printf ("The Objective Caml parser generator, version "
+              printf ("The OCaml parser generator, version "
                       OCAML_VERSION "\n");
               exit (0);
             }else if (!strcmp (argv[i], "-vnum")){
diff --git a/yacc/mkpar.c b/yacc/mkpar.c
index 1f9759e1..0e20724b 100644
--- a/yacc/mkpar.c
+++ b/yacc/mkpar.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/output.c b/yacc/output.c
index 00d61ac9..9723d3fa 100644
--- a/yacc/output.c
+++ b/yacc/output.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/reader.c b/yacc/reader.c
index d3c27557..1c36843d 100644
--- a/yacc/reader.c
+++ b/yacc/reader.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/skeleton.c b/yacc/skeleton.c
index 86e152ac..8048999d 100644
--- a/yacc/skeleton.c
+++ b/yacc/skeleton.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/symtab.c b/yacc/symtab.c
index 87e280a0..f30e4a90 100644
--- a/yacc/symtab.c
+++ b/yacc/symtab.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/verbose.c b/yacc/verbose.c
index 0a1850ff..799c4969 100644
--- a/yacc/verbose.c
+++ b/yacc/verbose.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
diff --git a/yacc/warshall.c b/yacc/warshall.c
index 5b8f10c8..c9ec782b 100644
--- a/yacc/warshall.c
+++ b/yacc/warshall.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */