diff options
| author | Luc Maranget <luc.maranget@inria.fr> | 2012-08-23 15:13:05 +0000 |
|---|---|---|
| committer | Luc Maranget <luc.maranget@inria.fr> | 2012-08-23 15:13:05 +0000 |
| commit | caa28b480be096eba860a2c5c9663028904f9ccc (patch) | |
| tree | b99121ba3d74f18cf79d94153afe1a9df057b50d | |
| parent | 32b0fd38483be6bfdf352676d44095fc1182601f (diff) | |
| download | ocaml-caa28b480be096eba860a2c5c9663028904f9ccc.tar.gz | |
Merge ocmal 4.00 r12217 -> r12778
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jo400@12875 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
346 files changed, 15988 insertions, 5670 deletions
@@ -30,12 +30,13 @@ 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/asttypes.cmi : parsing/location.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmi : utils/warnings.cmi parsing/longident.cmi : parsing/parse.cmi : parsing/parsetree.cmi -parsing/parser.cmi : parsing/parsetree.cmi +parsing/parser.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ parsing/asttypes.cmi parsing/printast.cmi : parsing/parsetree.cmi @@ -44,8 +45,6 @@ parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi utils/clflags.cmi parsing/lexer.cmi parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ parsing/location.cmx utils/clflags.cmx parsing/lexer.cmi -parsing/linenum.cmo : utils/misc.cmi -parsing/linenum.cmx : utils/misc.cmx parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \ parsing/location.cmi parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ @@ -70,15 +69,18 @@ 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/cmi_format.cmi : typing/types.cmi +typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/location.cmi typing/env.cmi typing/cmi_format.cmi typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -typing/datarepr.cmi : typing/types.cmi typing/path.cmi 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/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ + parsing/asttypes.cmi +typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \ + typing/path.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi utils/consistbl.cmi typing/annot.cmi typing/ident.cmi : -typing/includeclass.cmi : typing/types.cmi typing/typedtree.cmi \ - typing/env.cmi typing/ctype.cmi +typing/includeclass.cmi : typing/types.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 \ @@ -90,13 +92,15 @@ typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/env.cmi typing/oprint.cmi : typing/outcometree.cmi typing/outcometree.cmi : parsing/asttypes.cmi -typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \ - parsing/parsetree.cmi parsing/location.cmi typing/env.cmi +typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.cmi typing/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/printtyped.cmi : typing/typedtree.cmi typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ typing/annot.cmi typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi @@ -106,11 +110,13 @@ typing/typeclass.cmi : typing/types.cmi typing/typedtree.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 \ - parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ - typing/ident.cmi typing/env.cmi +typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/includecore.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.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 + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi parsing/asttypes.cmi typing/typejoin.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/location.cmi typing/ident.cmi typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ @@ -119,12 +125,25 @@ typing/typemod.cmi : typing/types.cmi typing/typedtree.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 \ - parsing/longident.cmi parsing/location.cmi typing/env.cmi +typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.cmi 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.cmi +typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi typing/cmi_format.cmi +typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx typing/cmi_format.cmi +typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi utils/misc.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/env.cmi utils/config.cmi \ + typing/cmi_format.cmi utils/clflags.cmi parsing/asttypes.cmi \ + typing/cmt_format.cmi +typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx utils/misc.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/env.cmx utils/config.cmx \ + typing/cmi_format.cmx utils/clflags.cmx parsing/asttypes.cmi \ + typing/cmt_format.cmi typing/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 \ @@ -134,21 +153,23 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.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/ident.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/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/datarepr.cmi typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ 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/cmi_format.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/annot.cmi typing/env.cmi typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ - typing/env.cmi + typing/cmi_format.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 \ @@ -219,6 +240,12 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ 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/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + parsing/asttypes.cmi typing/printtyped.cmi +typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + parsing/asttypes.cmi typing/printtyped.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 \ @@ -235,16 +262,18 @@ typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.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/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.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 \ 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/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.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/typejoin.cmi typing/typedtree.cmi \ typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \ @@ -252,8 +281,8 @@ typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \ parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ typing/joinmatching.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/cmt_format.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/typejoin.cmx typing/typedtree.cmx \ typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \ @@ -261,8 +290,8 @@ typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/joinmatching.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/cmt_format.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 \ @@ -280,11 +309,11 @@ typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.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 + utils/misc.cmi parsing/longident.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 \ - utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ - parsing/asttypes.cmi typing/typedtree.cmi + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi typing/typejoin.cmo : typing/types.cmi typing/typedtree.cmi \ parsing/location.cmi typing/ident.cmi typing/typejoin.cmi typing/typejoin.cmx : typing/types.cmx typing/typedtree.cmx \ @@ -295,36 +324,34 @@ typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.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/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ + typing/typemod.cmi 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/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ + typing/typemod.cmi typing/types.cmo : typing/primitive.cmi typing/path.cmi utils/misc.cmi \ 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/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.cmx : utils/warnings.cmx parsing/parsetree.cmi \ - parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi +typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi typing/typetexp.cmi +typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi typing/typetexp.cmi bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/bytelibrarian.cmi : bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi @@ -488,16 +515,16 @@ bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typejoin.cmi typing/typedtree.cmi bytecomp/translobj.cmi \ bytecomp/transljoin.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 + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/typejoin.cmx typing/typedtree.cmx bytecomp/translobj.cmx \ bytecomp/transljoin.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 + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/transljoin.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typejoin.cmi typing/typedtree.cmi typing/primitive.cmi \ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ @@ -810,7 +837,7 @@ driver/errors.cmo : utils/warnings.cmi typing/typetexp.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 \ + typing/cmi_format.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 \ @@ -818,7 +845,7 @@ driver/errors.cmx : utils/warnings.cmx typing/typetexp.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 \ + typing/cmi_format.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 \ @@ -850,16 +877,16 @@ driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \ bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \ parsing/location.cmi parsing/lexer.cmi typing/includemod.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 + typing/cmi_format.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 \ 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 \ parsing/location.cmx parsing/lexer.cmx typing/includemod.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 + typing/cmi_format.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/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \ driver/main_args.cmi parsing/location.cmi utils/config.cmi \ @@ -961,9 +988,9 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/types.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 \ + parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ + typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \ + typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ utils/config.cmi driver/compile.cmi utils/clflags.cmi \ bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ @@ -973,9 +1000,9 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/types.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 \ + parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ + typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \ + typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ utils/config.cmx driver/compile.cmx utils/clflags.cmx \ bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ @@ -6,9 +6,8 @@ OCaml 4.00.0: - 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. +- Added Generalized Abstract Data Types (GADTs) to the language. + See chapter "Language extensions" of the reference manual for documentation. - 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. @@ -21,6 +20,11 @@ Compilers: * 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. +- Added option -bin-annot to dump the AST with type annotations. +- Added lots of new warnings about unused variables, opens, fields, + constructors, etc. +* New meaning for warning 7: it is now triggered when a method is overridden + with the "method" keyword. Use "method!" to avoid the warning. Native-code compiler: - Optimized handling of partially-applied functions (PR#5287) @@ -32,10 +36,23 @@ Native-code compiler: 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) +- Generation of CFI information, and filename/line number debugging (with -g) + 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. + +OCamldoc: +- PR#5645: ocamldoc doesn't handle module/type substitution in signatures +- PR#5544: improve HTML output (less formatting in html code) +- PR#5522: allow refering to record fields and variant constructors +- fix PR#5419 (error message in french) +- fix PR#5535 (no cross ref to class after dump+load) +* Use first class modules for custom generators, to be able to + load various plugins incrementally adding features to the current + generator +* PR#5507: Use Location.t structures for locations. +- fix: do not keep code when not told to keep code. Standard library: - Added float functions "hypot" and "copysign" (PR#3806, PR#4752, PR#5246) @@ -46,17 +63,49 @@ Standard library: * 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. + . Added optional "random" parameter to Hashtbl.create to randomize + collision patterns and improve security (PR#5572, CVE-2012-0839) + . Added "randomize" function and "R" parameter to OCAMLRUNPARAM + to turn randomization on by default (PR#5572, CVE-2012-0839) + . Added new functorial interface "MakeSeeded" to support randomization + with user-provided seeded hash functions. + . Install new header <caml/hash.h> for C code. +- Filename: on-demand (lazy) initialization of the PRNG used by "temp_file". +- 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 (changes the generated sequences) - Scanf: new function "unescaped" (PR#3888) - Set and Map: more efficient implementation of "filter" and "partition" - String: new function "map" (PR#3888) +Installation procedure: +- Compiler internals are now installed in `ocamlc -where`/compiler-libs. + The files available there include the .cmi interfaces for all compiler + modules, plus the following libraries: + ocamlcommon.cma/.cmxa modules common to ocamlc, ocamlopt, ocaml + ocamlbytecomp.cma/.cmxa modules for ocamlc and ocaml + ocamloptcomp.cma/.cmxa modules specific to ocamlopt + ocamltoplevel.cma modules specific to ocaml + (PR#1804, PR#4653, frequently-asked feature). +* Some .cmi for toplevel internals that used to be installed in + `ocamlc -where` are now to be found in `ocamlc -where`/compiler-libs. + Add "-I +compiler-libs" where needed. +* toplevellib.cma is no longer installed because subsumed by + ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma +- Added a configuration option (-with-debug-runtime) to compile and install + a debug version of the runtime system, and a compiler option + (-runtime-variant) to select the debug runtime. + Bug Fixes: - PR#1643: functions of the Lazy module whose named started with 'lazy_' have been deprecated, and new ones without the prefix added -- PR#4549: Filename.dirname is not handling multiple / on Unix +- PR#3571: in Bigarrays, call msync() before unmapping to commit changes +- PR#4292: various documentation problems +- PR#4511, PR#4838: local modules remove polymorphism +* 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 @@ -64,45 +113,89 @@ Bug Fixes: - 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#5024: camlp4r now handles underscores in irrefutable pattern 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#5073: wrong location for 'Unbound record field label' error +- PR#5084: sub-sub-module building fails for native code compilation +- PR#5120: fix the output function of Camlp4.Debug.formatter +- PR#5131: compilation of custom runtime with g++ generates lots of warnings +- PR#5137: caml-types-explore does not work +- PR#5159: better documentation of type Lexing.position +- PR#5171: Map.join does more comparisons than needed +- PR#5176: emacs mode: stack overflow in regexp matcher +- PR#5179: port OCaml to mingw-w64 - PR#5211: updated Genlex documentation to state that camlp4 is mandatory for 'parser' keyword and associated notation +- PR#5214: ocamlfind plugin invokes 'cut' utility +- PR#5218: use $(MAKE) instead of "make" in Makefiles +- PR#5224: confusing error message in non-regular type definition +- PR#5231: camlp4: fix parsing of <:str_item< type t = $x$ >> +- PR#5233: finaliser on weak array gives dangling pointers (crash) - PR#5238, PR#5277: Sys_error when getting error location +- PR#5261, PR#5497: Ocaml source-code examples are not "copy-paste-able" +* PR#5279: executable name is not initialized properly in caml_startup_code +- PR#5290: added hash functions for channels, nats, mutexes, conditions +- PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5301: camlp4r and exception equal to another one with parameters +- PR#5305: prevent ocamlbuild from complaining about links to _build/ +- PR#5306: comparing to Thread.self() raises exception at runtime - 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#5312: command-line arguments @reponsefile auto-expansion feature + removed from the Windows OCaml runtime, to avoid conflicts with "-w @..." - PR#5313: ocamlopt -g misses optimizations - PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable +- PR#5318: segfault on stack overflow when reading marshaled data +- PR#5319: %r11 clobbered by Lswitch in Windows AMD64 native-code compilation - PR#5322: type abbreviations expanding to a universal type variable - PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in another thread -- PR#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#5338: sanitize.sh has windows style end-of-lines (mingw) - PR#5343: ocaml -rectypes is unsound wrt module subtyping -- PR#5344: some predifined exceptions need special printing +- PR#5344: some predefined exceptions need special printing +- PR#5349: Hashtbl.replace uses new key instead of reusing old key - PR#5356: ocamlbuild handling of 'predicates' for ocamlfind - PR#5364: wrong compilation of "((val m : SIG1) : SIG2)" - PR#5370: ocamldep omits filename in syntax error message +- PR#5374: camlp4 creates wrong location for type definitions - PR#5380: strange sscanf input segfault -- PR#5394: Documentation for -dtypes is missing in manpage +- PR#5382: EOPNOTSUPP and ENOTSUPP different on exotic platforms +- PR#5383: build failure in Win32/MSVC +- PR#5387: camlp4: str_item and other syntactic elements with Nils are + not very usable +- PR#5389: compaction sometimes leaves a very large heap +- PR#5393: fails to build from source on GNU/kFreeBSD because of -R link option +- PR#5394: documentation for -dtypes is missing in manpage +- PR#5397: Filename.temp_dir_name should be mutable +- PR#5410: fix printing of class application with Camlp4 - PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode +- PR#5435: ocamlbuild does not find .opt executables on Windows - PR#5436: update object ids on unmarshaling +- PR#5442: camlp4: quotation issue with strings - 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#5465: increase stack size of ocamlopt.opt for windows - 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#5477: use pkg-config to configure graphics on linux +- PR#5481: update camlp4 magic numbers +- PR#5482: remove bashism in test suite scripts +- PR#5495: camlp4o dies on infix definition (or) - 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 @@ -111,40 +204,118 @@ Bug Fixes: - 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 / GCC flexible array types if possible +- PR#5516: in Bigarray C stubs, use C99 flexible array types if possible +- PR#5518: segfault with lazy empty array +- PR#5531: Allow ocamlbuild to add ocamldoc flags through -docflag + and -docflags switches +- PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file +- PR#5538: combining -i and -annot in ocamlc +- PR#5648: (probably fixed) test failures in tests/lib-threads +- PR#5551: repeated calls to find_in_path degrade performance +- PR#5552: Mac OS X: unrecognized gcc option "-no-cpp-precomp" +- PR#5555: add Hashtbl.reset to resize the bucket table to its initial size +- PR#5560: incompatible type for tuple pattern with -principal +- PR#5575: Random states are not marshallable across architectures +- PR#5579: camlp4: when a plugin is loaded in the toplevel, + Token.Filter.define_filter has no effect before the first syntax error +- PR#5585: typo: "explicitely" +- PR#5587: documentation: "allows to" is not correct English +- PR#5593: remove C file when -output-obj fails +- PR#5597: register names for instrtrace primitives in embedded bytecode +- PR#5598: add backslash-space support in strings in ocamllex +- PR#5603: wrong .file debug info generated by ocamlopt -g +- PR#5604: fix permissions of files created by ocamlbuild itself +- PR#5610: new unmarshaler (from PR#5318) fails to freshen object identifiers +- PR#5614: add missing -linkall flag when compiling ocamldoc.opt +- PR#5616: move ocamlbuild documentation to the reference manual +- PR#5619: Uncaught CType.Unify exception in the compiler +- PR#5620: invalid printing of type manifest (camlp4 revised syntax) +- PR#5637: invalid printing of anonymous type parameters (camlp4 revised syntax) +- PR#5643: issues with .cfi and .loc directives generated by ocamlopt -g +- PR#5644: Stream.count broken when used with Sapp or Slazy nodes +- PR#5647: Cannot use install_printer in debugger +- PR#5651: printer for abstract data type (camlp4 revised syntax) +- PR#5654: self pattern variable location tweak +- PR#5655: ocamlbuild doesn't pass cflags when building C stubs +- PR#5657: wrong error location for abbreviated record fields +- PR#5659: ocamlmklib -L option breaks with MSVC +- PR#5661: fixes for the test suite +- PR#5668: Camlp4 produces invalid syntax for "let _ = ..." +- PR#5671: initialization of compare_ext field in caml_final_custom_operations() +- PR#5677: do not use "value" as identifier (genprintval.ml) +- PR#5687: dynlink broken when used from "output-obj" main program (bytecode) - problem with printing of string literals in camlp4 (reported on caml-list) - emacs mode: colorization of comments and strings now works correctly +- problem with forall and method (reported on caml-list on 2011-07-26) +- crash when using OCAMLRUNPARAM=a=X with invalid X (reported in private) Feature wishes: - PR#352: new option "-stdin" to make ocaml read stdin as a script +- PR#1164: better error message when mixing -a and .cmxa +- PR#1284: documentation: remove restriction on mixed streams +- PR#1496: allow configuring LIBDIR, BINDIR, and MANDIR relative to $(PREFIX) +- PR#1835: add Digest.from_hex +- PR#1898: toplevel: add option to suppress continuation prompts +- PR#4278: configure: option to disable "graph" library - PR#4444: new String.trim function, removing leading and trailing whistespace +- PR#4549: make Filename.dirname/basename POSIX compliant +- PR#4830: add option -v to expunge.ml - PR#4898: new Sys.big_endian boolean for machine endianness +- PR#4963, PR#5467: no extern "C" into ocaml C-stub headers - 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#5215: marshalling of dynlinked closure - PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x', and '%apply' with semantics 'apply f x = f x'. +- PR#5255: natdynlink detection on powerpc, hurd, sparc +- PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5297: compiler now checks existence of builtin primitives - PR#5329: (Windows) more efficient Unix.select if all fd's are sockets +- PR#5357: warning for useless open statements - PR#5358: first class modules don't allow "with type" declarations for types in sub-modules +- PR#5385: configure: emit a warning when MACOSX_DEPLOYMENT_TARGET is set +- PR#5396: ocamldep: add options -sort, -all, and -one-line +- PR#5397: Filename.temp_dir_name should be mutable +- PR#5403: give better error message when emacs is not found in PATH - PR#5411: new directive for the toplevel: #load_rec - PR#5420: Unix.openfile share mode (Windows) -- PR#5437: warning for useless open statements +- PR#5421: Unix: do not leak fds in various open_proc* functions +- PR#5434: implement Unix.times in win32unix (partially) - PR#5438: new warnings for unused declarations +- PR#5439: upgrade config.guess and config.sub +- PR#5445 and others: better printing of types with user-provided names - PR#5454: Digest.compare is missing and md5 doc update -- PR#5467: no extern "C" into ocaml C-stub headers +- PR#5455: .emacs instructions, add lines to recognize ocaml scripts +- PR#5456: pa_macro: replace __LOCATION__ after macro expansion; add LOCATION_OF +- PR#5461: bytecode: emit warning when linking two modules with the same name - PR#5478: ocamlopt assumes ar command exists - PR#5479: Num.num_of_string may raise an exception, not reflected in the documentation. +- PR#5501: increase IO_BUFFER_SIZE to 64KiB +- PR#5532: improve error message when bytecode file is wrong +- PR#5555: add function Hashtbl.reset to resize the bucket table to + its initial size. +- PR#5586: increase UNIX_BUFFER_SIZE to 64KiB +- PR#5597: register names for instrtrace primitives in embedded bytecode +- PR#5599: Add warn() tag in ocamlbuild to control -w compiler switch +- PR#5628: add #remove_directory and Topdirs.remove_directory to remove + a directory from the load path +- PR#5636: in system threads library, issue with linking of pthread_atfork +- PR#5666: C includes don't provide a revision number - ocamldebug: ability to inspect values that contain code pointers - ocamldebug: new 'environment' directive to set environment variables - for debugee + for debuggee +- configure: add -no-camlp4 option 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. @@ -2873,5 +3044,3 @@ Caml Special Light 1.06: ------------------------ * First public release. - -$Id$ @@ -22,7 +22,7 @@ include otherlibs/join/StdJoinModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot $(NOJOIN) CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink $(NOJOIN) -COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES) +COMPFLAGS= -annot -strict-sequence -warn-error A $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -45,8 +45,6 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo utils/extarray.cmo utils/agraph.cmo -OPTUTILS=$(UTILS) - PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo @@ -55,13 +53,13 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ typing/btype.cmo typing/oprint.cmo \ typing/subst.cmo typing/predef.cmo \ - typing/datarepr.cmo typing/env.cmo \ - typing/typedtree.cmo typing/ctype.cmo \ + typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \ + typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/includecore.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/typejoin.cmo typing/joinmatching.cmo \ - typing/stypes.cmo typing/typecore.cmo \ + typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -70,12 +68,16 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/transljoin.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ - bytecomp/simplif.cmo bytecomp/runtimedef.cmo + bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ + driver/pparse.cmo driver/main_args.cmo + +COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ - bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo + bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ + driver/errors.cmo driver/compile.cmo ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ @@ -90,45 +92,22 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ - asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo - -DRIVER=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - driver/main_args.cmo driver/main.cmo + asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ + driver/opterrors.cmo driver/optcompile.cmo -OPTDRIVER= driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ - driver/main_args.cmo driver/optmain.cmo - -TOPLEVEL=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - driver/main_args.cmo toplevel/genprintval.cmo toplevel/toploop.cmo \ +TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \ toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo -TOPLEVELLIB=toplevel/toplevellib.cma -TOPLEVELSTART=toplevel/topstart.cmo +BYTESTART=driver/main.cmo -COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER) +OPTSTART=driver/optmain.cmo -TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) - -TOPOBJS=$(TOPLEVELLIB)\ - otherlibs/unix/unix.cma otherlibs/systhreads/threads.cma\ - otherlibs/join/join.cma\ - $(TOPLEVELSTART) +TOPLEVELSTART=toplevel/topstart.cmo -NATTOPOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ - driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ - driver/main_args.cmo \ +NATTOPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \ toplevel/opttopmain.cmo toplevel/opttopstart.cmo -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 - PERVASIVES=$(STDLIB_MODULES) $(JOIN_MODULES) $(STDJOIN_MODULES) join_prim outcometree topdirs toploop # For users who don't read the INSTALL file @@ -156,6 +135,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) @@ -265,9 +245,14 @@ cleanboot: # Compile the native-code compiler -opt-core:runtimeopt ocamlopt libraryopt -opt-center:opt-core otherlibrariesopt -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt +opt: + $(MAKE) runtimeopt + $(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 \ @@ -280,10 +265,14 @@ base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ otherlibrariesopt # Installation + +COMPLIBDIR=$(LIBDIR)/compiler-libs + install: if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi + if test -d $(COMPLIBDIR); then : ; else $(MKDIR) $(COMPLIBDIR); fi # if test -d $(MANDIR)/man$(MANEXT); then : ; \ # else $(MKDIR) $(MANDIR)/man$(MANEXT); fi cp VERSION $(LIBDIR)/ @@ -296,12 +285,10 @@ install: cd stdlib; $(MAKE) install cp lex/ocamllex $(BINDIR)/jocamllex$(EXE) cp yacc/ocamlyacc$(EXE) $(BINDIR)/jocamlyacc$(EXE) - cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma + cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR) + cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR) cp expunge $(LIBDIR)/expunge$(EXE) - cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR) - cp toplevel/topstart.cmo $(LIBDIR) - cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi \ - $(LIBDIR) + cp toplevel/topdirs.cmi $(LIBDIR) cd tools; $(MAKE) install # -$(MAKE) -C man install for i in $(OTHERLIBRARIES); do \ @@ -321,33 +308,59 @@ installopt: cd asmrun; $(MAKE) install cp ocamlopt $(BINDIR)/jocamlopt$(EXE) cd stdlib; $(MAKE) installopt + cp asmcomp/*.cmi $(COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) # cd ocamldoc; $(MAKE) installopt for i in $(OTHERLIBRARIES); \ do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done - if test -f ocamlc.opt; \ - then cp ocamlc.opt $(BINDIR)/jocamlc.opt$(EXE); else :; fi - if test -f ocamlopt.opt; \ - then cp ocamlopt.opt $(BINDIR)/jocamlopt.opt$(EXE); else :; fi - if test -f lex/ocamllex.opt; \ - then cp lex/ocamllex.opt $(BINDIR)/jocamllex.opt$(EXE); else :; fi + if test -f ocamlopt.opt ; then $(MAKE) installoptopt; fi + cd tools; $(MAKE) installopt + +installoptopt: + cp ocamlc.opt $(BINDIR)/jocamlc.opt$(EXE) + cp ocamlopt.opt $(BINDIR)/jocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(BINDIR)/jocamllex.opt$(EXE) + cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ + compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ + compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ + $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ + $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ + $(COMPLIBDIR) + cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a ocamloptcomp.a clean:: partialclean -# The compiler +# Shared parts of the system + +compilerlibs/ocamlcommon.cma: $(COMMON) + $(CAMLC) -a -o $@ $(COMMON) +partialclean:: + rm -f compilerlibs/ocamlcommon.cma + +# The bytecode compiler + +compilerlibs/ocamlbytecomp.cma: $(BYTECOMP) + $(CAMLC) -a -o $@ $(BYTECOMP) +partialclean:: + rm -f compilerlibs/ocamlbytecomp.cma -ocamlc: $(COMPOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS) +ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) + $(CAMLC) $(LINKFLAGS) -o ocamlc \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh -partialclean:: - rm -f ocamlc ocamlcomp.sh - # The native-code compiler -ocamlopt: $(OPTOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlopt $(OPTOBJS) +compilerlibs/ocamloptcomp.cma: $(ASMCOMP) + $(CAMLC) -a -o $@ $(ASMCOMP) +partialclean:: + rm -f compilerlibs/ocamloptcomp.cma + +ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) + $(CAMLC) $(LINKFLAGS) -o ocamlopt \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh @@ -357,30 +370,20 @@ partialclean:: # The toplevel -toplibs: - for i in unix systhreads threads ; do \ - (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ - done - (cd otherlibs/join; $(MAKE) join.cma) || exit $$? - -toplibsopt: - for i in unix systhreads threads ; do \ - (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \ - done - (cd otherlibs/join; $(MAKE) join.cmxa) || exit $$? - +compilerlibs/ocamltoplevel.cma: $(TOPLEVEL) + $(CAMLC) -a -o $@ $(TOPLEVEL) +partialclean:: + rm -f compilerlibs/ocamltoplevel.cma -ocaml: toplibs $(TOPOBJS) expunge - $(CAMLC) $(LINKFLAGS) -thread -I otherlibs/unix -I otherlibs/systhreads -I otherlibs/join \ - -linkall -o ocaml.tmp $(TOPOBJS) - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) +ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge + $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) + - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) rm -f ocaml.tmp -toplevel/toplevellib.cma: $(TOPLIB) - $(CAMLC) -a -o $@ $(TOPLIB) - partialclean:: - rm -f ocaml toplevel/toplevellib.cma + rm -f ocaml # The native toplevel @@ -391,7 +394,7 @@ ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml - cd otherlibs/dynlink && make allopt + cd otherlibs/dynlink && $(MAKE) allopt # The configuration file @@ -449,13 +452,24 @@ partialclean:: beforedepend:: parsing/lexer.ml +# Shared parts of the system compiled with the native-code compiler + +compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a + # The bytecode compiler compiled with the native-code compiler -ocamlc.opt: $(COMPOBJS:.cmo=.cmx) - cd asmrun; $(MAKE) meta.o dynlink.o +compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a + +ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ - $(COMPOBJS:.cmo=.cmx) \ - asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)" + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ + $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh @@ -465,8 +479,15 @@ partialclean:: # The native-code compiler compiled with itself -ocamlopt.opt: $(OPTOBJS:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt $(OPTOBJS:.cmo=.cmx) +compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a + +ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + $(OPTSTART:.cmo=.cmx) @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh @@ -474,7 +495,7 @@ ocamlopt.opt: $(OPTOBJS:.cmo=.cmx) partialclean:: rm -f ocamlopt.opt -$(OPTOBJS:.cmo=.cmx): ocamlopt +$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes @@ -565,8 +586,9 @@ tools/cvt_emit: tools/cvt_emit.mll # The "expunge" utility -expunge: $(EXPUNGEOBJS) - $(CAMLC) $(LINKFLAGS) -o expunge $(EXPUNGEOBJS) +expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo + $(CAMLC) $(LINKFLAGS) -o expunge \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo partialclean:: rm -f expunge @@ -643,6 +665,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 @@ -726,7 +751,7 @@ clean:: package-macosx: sudo rm -rf package-macosx/root - make PREFIX="`pwd`"/package-macosx/root install + $(MAKE) PREFIX="`pwd`"/package-macosx/root install tools/make-package-macosx sudo rm -rf package-macosx/root @@ -767,8 +792,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 18984fb4e2..16da8f2b15 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -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 @@ -35,8 +38,6 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo -OPTUTILS=$(UTILS) - PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo @@ -45,12 +46,13 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ typing/btype.cmo typing/oprint.cmo \ typing/subst.cmo typing/predef.cmo \ - typing/datarepr.cmo typing/env.cmo \ + typing/datarepr.cmo typing/cmi_format.cmo typing/env.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/typetexp.cmo \ + typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -58,12 +60,16 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ - bytecomp/simplif.cmo bytecomp/runtimedef.cmo + bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ + driver/pparse.cmo driver/main_args.cmo + +COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ - bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo + bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ + driver/errors.cmo driver/compile.cmo ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ @@ -78,41 +84,17 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ - asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo - -DRIVER=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - driver/main_args.cmo driver/main.cmo - -OPTDRIVER=driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ - driver/main_args.cmo driver/optmain.cmo + asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ + driver/opterrors.cmo driver/optcompile.cmo -TOPLEVEL=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \ - driver/main_args.cmo toplevel/genprintval.cmo toplevel/toploop.cmo \ +TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \ toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo -TOPLEVELLIB=toplevel/toplevellib.cma -TOPLEVELSTART=toplevel/topstart.cmo - -COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER) - -TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) - -TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART) +BYTESTART=driver/main.cmo -NATTOPOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ - driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ - driver/main_args.cmo \ - toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \ - toplevel/opttopmain.cmo toplevel/opttopstart.cmo +OPTSTART=driver/optmain.cmo -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 +TOPLEVELSTART=toplevel/topstart.cmo PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree @@ -121,7 +103,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. @@ -217,29 +200,31 @@ opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ world.opt: coldstart opt.opt # Installation + +COMPLIBDIR=$(LIBDIR)/compiler-libs + install: installbyt installopt installbyt: mkdir -p $(BINDIR) mkdir -p $(LIBDIR) + mkdir -p $(COMPLIBDIR) cd byterun ; $(MAKEREC) install cp ocamlc $(BINDIR)/ocamlc.exe cp ocaml $(BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install cp lex/ocamllex $(BINDIR)/ocamllex.exe cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe - cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma + cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR) + cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR) cp expunge $(LIBDIR)/expunge.exe - cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR) - cp toplevel/topstart.cmo $(LIBDIR) - cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR) + cp toplevel/topdirs.cmi $(LIBDIR) cd tools ; $(MAKEREC) install cd ocamldoc ; $(MAKEREC) install mkdir -p $(STUBLIBDIR) 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 @@ -252,49 +237,78 @@ installopt: cd asmrun ; $(MAKEREC) install cp ocamlopt $(BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt + cp asmcomp/*.cmi driver/*.cmi $(COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) cd ocamldoc ; $(MAKEREC) installopt for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done - if test -f ocamlc.opt; \ - then cp ocamlc.opt $(BINDIR)/ocamlc.opt.exe; else :; fi - if test -f ocamlopt.opt; \ - 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 + if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi + +installoptopt: + cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ + compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ + compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ + $(COMPLIBDIR) clean:: partialclean # The compiler -ocamlc: $(COMPOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS) +compilerlibs/ocamlcommon.cma: $(COMMON) + $(CAMLC) -a -o $@ $(COMMON) +partialclean:: + rm -f compilerlibs/ocamlcommon.cma + +# The bytecode compiler + +compilerlibs/ocamlbytecomp.cma: $(BYTECOMP) + $(CAMLC) -a -o $@ $(BYTECOMP) +partialclean:: + rm -f compilerlibs/ocamlbytecomp.cma + +ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) + $(CAMLC) $(LINKFLAGS) -o ocamlc \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh partialclean:: - rm -f ocamlc + rm -f ocamlc ocamlcomp.sh # The native-code compiler -ocamlopt: $(OPTOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlopt $(OPTOBJS) +compilerlibs/ocamloptcomp.cma: $(ASMCOMP) + $(CAMLC) -a -o $@ $(ASMCOMP) +partialclean:: + rm -f compilerlibs/ocamloptcomp.cma + +ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) + $(CAMLC) $(LINKFLAGS) -o ocamlopt \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt + rm -f ocamlopt ocamlcompopt.sh # The toplevel -ocaml: $(TOPOBJS) expunge - $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp $(TOPOBJS) +compilerlibs/ocamltoplevel.cma: $(TOPLEVEL) + $(CAMLC) -a -o $@ $(TOPLEVEL) +partialclean:: + rm -f compilerlibs/ocamltoplevel.cma + +ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge + $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) rm -f ocaml.tmp -toplevel/toplevellib.cma: $(TOPLIB) - $(CAMLC) -a -o $@ $(TOPLIB) - partialclean:: rm -f ocaml @@ -306,7 +320,7 @@ ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml - cd otherlibs/dynlink && make allopt + cd otherlibs/dynlink && $(MAKE) allopt # The configuration file @@ -368,11 +382,24 @@ partialclean:: beforedepend:: parsing/lexer.ml +# Shared parts of the system compiled with the native-code compiler + +compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) + # The bytecode compiler compiled with the native-code compiler -ocamlc.opt: $(COMPOBJS:.cmo=.cmx) - cd asmrun ; $(MAKEREC) meta.$(O) dynlink.$(O) - $(CAMLOPT) $(LINKFLAGS) -o ocamlc.opt $(COMPOBJS:.cmo=.cmx) asmrun/meta.$(O) asmrun/dynlink.$(O) +compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) + +ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ + $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh @@ -382,8 +409,15 @@ partialclean:: # The native-code compiler compiled with itself -ocamlopt.opt: $(OPTOBJS:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt $(OPTOBJS:.cmo=.cmx) +compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) + +ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + $(OPTSTART:.cmo=.cmx) @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh @@ -391,7 +425,7 @@ ocamlopt.opt: $(OPTOBJS:.cmo=.cmx) partialclean:: rm -f ocamlopt.opt -$(OPTOBJS:.cmo=.cmx): ocamlopt +$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes @@ -486,8 +520,9 @@ tools/cvt_emit: tools/cvt_emit.mll # The "expunge" utility -expunge: $(EXPUNGEOBJS) - $(CAMLC) $(LINKFLAGS) -o expunge $(EXPUNGEOBJS) +expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo + $(CAMLC) $(LINKFLAGS) -o expunge \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo partialclean:: rm -f expunge @@ -616,14 +651,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 @@ -1,4 +1,4 @@ -4.00.0+dev13 (2012-03-08) +4.00.0+dev24_2012-07-26 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli @@ -17,7 +17,7 @@ true: -traverse # Traverse only these directories <{bytecomp,driver,stdlib,tools,asmcomp,camlp4,ocamlbuild,toplevel,ocamldoc,typing,otherlibs,utils,debugger,lex,parsing,byterun,asmrun}/**>: traverse -"boot" or "byterun" or "asmrun": not_hygienic +"boot" or "byterun" or "asmrun" or "compilerlibs": not_hygienic # These should not be required but it fails on *BSD and Windows... "yacc" or "win32caml": not_hygienic diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 7dd55c964f..2ff57dd437 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -396,7 +396,9 @@ let emit_instr fallthrough i = if alloc then begin ` {load_symbol_addr s}, %rax\n`; ` {emit_call "caml_c_call"}\n`; - record_frame i.live i.dbg + record_frame i.live i.dbg; + ` {load_symbol_addr "caml_young_ptr"}, %r11\n`; + ` movq (%r11), %r15\n`; end else begin ` {emit_call s}\n` end @@ -769,6 +771,7 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + reset_debug_info(); (* PR#5603 *) if !Clflags.dlcode then begin (* from amd64.S; could emit these constants on demand *) if macosx then diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 846ee4ae3b..b0baf86523 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -243,11 +243,28 @@ let emit_intconst dst n = (* Adjust sp (up or down) by the given byte amount *) -let emit_stack_adjustment instr n = - if n <= 0 then 0 else - decompose_intconst (Int32.of_int n) - (fun bits -> - ` {emit_string instr} sp, sp, #{emit_int32 bits}\n`) +let emit_stack_adjustment n = + if n = 0 then 0 else begin + let instr = if n < 0 then "sub" else "add" in + let ninstr = decompose_intconst (Int32.of_int (abs n)) + (fun bits -> + ` {emit_string instr} sp, sp, #{emit_int32 bits}\n`) in + cfi_adjust_cfa_offset (-n); + ninstr + end + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue f = + let n = frame_size() in + if n > 0 then begin + let ninstr = emit_stack_adjustment n in + let ninstr = ninstr + f () in + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n; + ninstr + end else + f () (* Name of current function *) let function_name = ref "" @@ -347,6 +364,7 @@ let emit_load_symbol_addr dst s = (* Output the assembly code for an instruction *) let emit_instr i = + emit_debug_info i.dbg; match i.desc with Lend -> 0 | Lop(Imove | Ispill | Ireload) -> @@ -423,22 +441,20 @@ let emit_instr i = ` {emit_call s}\n`; `{record_frame i.live i.dbg}\n`; 1 | Lop(Itailcall_ind) -> - let n = frame_size() in - if !contains_calls then - ` ldr lr, [sp, #{emit_int (n-4)}]\n`; - let ninstr = emit_stack_adjustment "add" n in - ` bx {emit_reg i.arg.(0)}\n`; - 2 + ninstr + output_epilogue begin fun () -> + if !contains_calls then + ` ldr lr, [sp, #{emit_int (-4)}]\n`; + ` bx {emit_reg i.arg.(0)}\n`; 2 + end | Lop(Itailcall_imm s) -> if s = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; 1 end else begin - let n = frame_size() in - if !contains_calls then - ` ldr lr, [sp, #{emit_int (n-4)}]\n`; - let ninstr = emit_stack_adjustment "add" n in - ` {emit_jump s}\n`; - 2 + ninstr + output_epilogue begin fun () -> + if !contains_calls then + ` ldr lr, [sp, #{emit_int (-4)}]\n`; + ` {emit_jump s}\n`; 2 + end end | Lop(Iextcall(s, false)) -> ` {emit_call s}\n`; 1 @@ -449,10 +465,7 @@ let emit_instr i = 1 + ninstr | Lop(Istackoffset n) -> assert (n mod 8 = 0); - let ninstr = - if n >= 0 - then emit_stack_adjustment "sub" n - else emit_stack_adjustment "add" (-n) in + let ninstr = emit_stack_adjustment (-n) in stack_offset := !stack_offset + n; ninstr | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 -> @@ -672,9 +685,9 @@ let emit_instr i = let n = frame_size() in ` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1 | Lreturn -> - let ninstr = emit_stack_adjustment "add" (frame_size()) in - ` bx lr\n`; - ninstr + 1 + output_epilogue begin fun () -> + ` bx lr\n`; 1 + end | Llabel lbl -> `{emit_label lbl}:\n`; 0 | Lbranch lbl -> @@ -734,39 +747,50 @@ let emit_instr i = 4 | 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`; + (* The Thumb-2 TBH instruction supports only forward branches, + so we need to generate appropriate trampolines for all labels + that appear before this switch instruction (PR#5623) *) + let tramtbl = Array.copy jumptbl in + ` tbh [pc, {emit_reg i.arg.(0)}, lsl #1]\n`; + for j = 0 to Array.length tramtbl - 1 do + let rec label i = + match i.desc with + Lend -> new_label() + | Llabel lbl when lbl = tramtbl.(j) -> lbl + | _ -> label i.next in + tramtbl.(j) <- label i.next; + ` .short ({emit_label tramtbl.(j)}-.)/2+{emit_int j}\n` done; - ` .align 1\n`; - 2 + Array.length jumptbl / 2 + (* Generate the necessary trampolines *) + for j = 0 to Array.length tramtbl - 1 do + if tramtbl.(j) <> jumptbl.(j) then + `{emit_label tramtbl.(j)}: b {emit_label jumptbl.(j)}\n` + done + end else if not !pic_code then begin + ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; + ` nop\n`; + for j = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(j)}\n` + done 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 + (* Slightly slower, but position-independent *) + ` add pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`; + ` nop\n`; + for j = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(j)}\n` + done + end; + 2 + Array.length jumptbl | Lsetuptrap lbl -> ` bl {emit_label lbl}\n`; 1 | Lpushtrap -> stack_offset := !stack_offset + 8; ` push \{trap_ptr, lr}\n`; + cfi_adjust_cfa_offset 8; ` mov trap_ptr, sp\n`; 2 | Lpoptrap -> ` pop \{trap_ptr, lr}\n`; + cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 | Lraise -> if !Clflags.debug then begin @@ -831,16 +855,21 @@ let fundecl fundecl = ` .arm\n`; ` .type {emit_symbol fundecl.fun_name}, %function\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() in - ignore(emit_stack_adjustment "sub" n); - if !contains_calls then - ` str lr, [sp, #{emit_int(n - 4)}]\n`; + if n > 0 then begin + ignore(emit_stack_adjustment (-n)); + if !contains_calls then + ` str lr, [sp, #{emit_int(n - 4)}]\n` + end; `{emit_label !tailrec_entry_point}:\n`; emit_all 0 fundecl.fun_body; emit_literals(); List.iter emit_call_gc !call_gc_sites; List.iter emit_call_bound_error !bound_error_sites; + cfi_endproc(); ` .type {emit_symbol fundecl.fun_name}, %function\n`; ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n` @@ -869,6 +898,7 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + reset_debug_info(); ` .syntax unified\n`; begin match !arch with | ARMv4 -> ` .arch armv4t\n` diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index ec974774f5..0b5d09db7d 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1402,20 +1402,23 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = 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(make_checkbound 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(make_checkbound 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(make_checkbound 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" diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml index ab0f5c047a..19986f8378 100644 --- a/asmcomp/debuginfo.ml +++ b/asmcomp/debuginfo.ml @@ -31,11 +31,12 @@ let none = { dinfo_char_end = 0 } +(* PR#5643: cannot use (==) because Debuginfo values are marshalled *) let is_none t = - t == none + t = none let to_string d = - if d == none + if d = none then "" else Printf.sprintf "{%s:%d,%d-%d}" d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli index cf6179cd37..ef4d55ad91 100644 --- a/asmcomp/debuginfo.mli +++ b/asmcomp/debuginfo.mli @@ -12,7 +12,7 @@ type kind = Dinfo_call | Dinfo_raise -type t = { +type t = private { dinfo_kind: kind; dinfo_file: string; dinfo_line: int; diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 712b848f7e..034815c0d3 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -114,36 +114,6 @@ 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 = @@ -177,13 +147,13 @@ let emit_frames a = lbl in let emit_frame fd = a.efa_label fd.fd_lbl; - a.efa_16 (if fd.fd_debuginfo == Debuginfo.none + a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo then fd.fd_frame_size else fd.fd_frame_size + 1); a.efa_16 (List.length fd.fd_live_offset); List.iter a.efa_16 fd.fd_live_offset; a.efa_align Arch.size_addr; - if fd.fd_debuginfo != Debuginfo.none then begin + if not (Debuginfo.is_none fd.fd_debuginfo) then begin let d = fd.fd_debuginfo in let line = min 0xFFFFF d.dinfo_line and char_start = min 0xFF d.dinfo_char_start @@ -223,7 +193,7 @@ let is_generic_function name = (* CFI directives *) let is_cfi_enabled () = - !Clflags.debug && Config.asm_cfi_supported + Config.asm_cfi_supported let cfi_startproc () = if is_cfi_enabled () then @@ -238,4 +208,40 @@ let cfi_adjust_cfa_offset n = begin emit_string " .cfi_adjust_cfa_offset "; emit_int n; emit_string "\n"; end - + +(* 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 + +(* Reset debug state at beginning of asm file *) +let reset_debug_info () = + file_pos_nums := []; + file_pos_num_cnt := 1 + +(* We only diplay .file if the file has not been seen before. We + display .loc for every instruction. *) +let emit_debug_info dbg = + if is_cfi_enabled () && + !Clflags.debug && not (Debuginfo.is_none dbg) then begin + let line = dbg.Debuginfo.dinfo_line in + assert (line <> 0); (* clang errors out on zero line numbers *) + let file_name = dbg.Debuginfo.dinfo_file in + 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' + end diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index dd2f5b8c89..c7fe802e51 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -29,6 +29,7 @@ val emit_float64_directive: string -> string -> unit val emit_float64_split_directive: string -> string -> unit val emit_float32_directive: string -> string -> unit +val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit type frame_descr = diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index d52b1db670..78edea342c 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -988,6 +988,7 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + reset_debug_info(); (* PR#5603 *) let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index c0557244ba..c1323234a6 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -48,7 +48,7 @@ let size_float = 8 (* Behavior of division *) -let division_crashes_on_overflow = false +let division_crashes_on_overflow = true (* Operations on addressing modes *) diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 754a436120..0ac6e06551 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -65,7 +65,7 @@ let instr ppf i = | Lraise -> fprintf ppf "raise %a" reg i.arg.(0) end; - if i.dbg != Debuginfo.none then + if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) let rec all_instr ppf i = diff --git a/asmrun/.depend b/asmrun/.depend index 653a7553a0..92536795da 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -4,42 +4,21 @@ alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h -alloc.p.o: alloc.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h -array.p.o: array.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -backtrace.p.o: backtrace.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h -callback.p.o: callback.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ @@ -48,42 +27,20 @@ compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h -compact.p.o: compact.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h -compare.p.o: compare.p.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -custom.p.o: custom.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ ../byterun/misc.h -debugger.p.o: debugger.p.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 \ @@ -95,65 +52,33 @@ 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 -extern.p.o: extern.p.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 \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -fail.p.o: fail.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/io.h ../byterun/gc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h \ - ../byterun/memory.h finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/signals.h -finalise.p.o: finalise.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -floats.p.o: floats.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -freelist.p.o: freelist.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ @@ -162,64 +87,30 @@ gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h stack.h -gc_ctrl.p.o: gc_ctrl.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/globroots.h ../byterun/roots.h -globroots.p.o: globroots.p.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -hash.p.o: hash.p.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/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 -intern.p.o: intern.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h \ - ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -ints.p.o: ints.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -227,29 +118,14 @@ io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ ../byterun/sys.h -io.p.o: io.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h -lexing.p.o: lexing.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h main.o: main.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/sys.h -main.p.o: main.p.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ @@ -259,27 +135,12 @@ major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h -major_gc.p.o: major_gc.p.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ ../byterun/reverse.h -md5.p.o: md5.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ @@ -287,13 +148,6 @@ memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/signals.h -memory.p.o: memory.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ @@ -311,37 +165,18 @@ minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ ../byterun/weak.h -minor_gc.p.o: minor_gc.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h -misc.p.o: misc.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h -natdynlink.p.o: natdynlink.p.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - 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 \ @@ -349,33 +184,16 @@ obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h -obj.p.o: obj.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/alloc.h -parsing.p.o: parsing.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/printexc.h -printexc.p.o: printexc.p.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ @@ -383,13 +201,6 @@ roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h stack.h ../byterun/roots.h -roots.p.o: roots.p.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ @@ -398,48 +209,24 @@ signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ ../byterun/sys.h -signals.p.o: signals.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ signals_osdep.h stack.h -signals_asm.p.o: signals_asm.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/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 -startup.p.o: startup.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h + ../byterun/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 str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h -str.p.o: str.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -447,83 +234,41 @@ sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -sys.p.o: sys.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ ../byterun/io.h ../byterun/mlvalues.h -terminfo.p.o: terminfo.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h unix.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/osdeps.h -unix.p.o: unix.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h -weak.p.o: weak.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/mlvalues.h alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h -alloc.p.d.o: alloc.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h -array.p.d.o: array.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -backtrace.p.d.o: backtrace.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h -callback.p.d.o: callback.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ @@ -532,42 +277,20 @@ compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h -compact.p.d.o: compact.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h -compare.p.d.o: compare.p.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -custom.p.d.o: custom.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ ../byterun/misc.h -debugger.p.d.o: debugger.p.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 \ @@ -579,65 +302,33 @@ 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 -extern.p.d.o: extern.p.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 \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -fail.p.d.o: fail.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/io.h ../byterun/gc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h \ - ../byterun/memory.h finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/signals.h -finalise.p.d.o: finalise.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -floats.p.d.o: floats.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -freelist.p.d.o: freelist.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ @@ -646,64 +337,30 @@ gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h stack.h -gc_ctrl.p.d.o: gc_ctrl.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/globroots.h ../byterun/roots.h -globroots.p.d.o: globroots.p.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -hash.p.d.o: hash.p.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/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 -intern.p.d.o: intern.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h \ - ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -ints.p.d.o: ints.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -711,29 +368,14 @@ io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ ../byterun/sys.h -io.p.d.o: io.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h -lexing.p.d.o: lexing.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h main.d.o: main.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/sys.h -main.p.d.o: main.p.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ @@ -743,27 +385,12 @@ major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h -major_gc.p.d.o: major_gc.p.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ ../byterun/reverse.h -md5.p.d.o: md5.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ @@ -771,13 +398,6 @@ memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/signals.h -memory.p.d.o: memory.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ @@ -795,37 +415,18 @@ minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ ../byterun/weak.h -minor_gc.p.d.o: minor_gc.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h -misc.p.d.o: misc.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h -natdynlink.p.d.o: natdynlink.p.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - 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 \ @@ -833,33 +434,16 @@ obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h -obj.p.d.o: obj.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/alloc.h -parsing.p.d.o: parsing.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/printexc.h -printexc.p.d.o: printexc.p.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ @@ -867,13 +451,6 @@ roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h stack.h ../byterun/roots.h -roots.p.d.o: roots.p.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ @@ -882,48 +459,24 @@ signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ ../byterun/sys.h -signals.p.d.o: signals.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ signals_osdep.h stack.h -signals_asm.p.d.o: signals_asm.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/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 -startup.p.d.o: startup.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h + ../byterun/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 str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h -str.p.d.o: str.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -931,83 +484,41 @@ sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -sys.p.d.o: sys.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.d.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ ../byterun/io.h ../byterun/mlvalues.h -terminfo.p.d.o: terminfo.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h unix.d.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/osdeps.h -unix.p.d.o: unix.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h -weak.p.d.o: weak.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/mlvalues.h alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h -alloc.p.p.o: alloc.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h -array.p.p.o: array.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -backtrace.p.p.o: backtrace.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h -callback.p.p.o: callback.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ @@ -1016,42 +527,20 @@ compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h -compact.p.p.o: compact.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h -compare.p.p.o: compare.p.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -custom.p.p.o: custom.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ ../byterun/misc.h -debugger.p.p.o: debugger.p.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 \ @@ -1063,65 +552,33 @@ 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 -extern.p.p.o: extern.p.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 \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -fail.p.p.o: fail.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/io.h ../byterun/gc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h \ - ../byterun/memory.h finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/signals.h -finalise.p.p.o: finalise.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -floats.p.p.o: floats.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -freelist.p.p.o: freelist.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ @@ -1130,64 +587,30 @@ gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h stack.h -gc_ctrl.p.p.o: gc_ctrl.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/globroots.h ../byterun/roots.h -globroots.p.p.o: globroots.p.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -hash.p.p.o: hash.p.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h \ - ../byterun/md5.h -intern.p.p.o: intern.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/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/misc.h ../byterun/reverse.h ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -ints.p.p.o: ints.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -1195,29 +618,14 @@ io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ ../byterun/sys.h -io.p.p.o: io.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h -lexing.p.p.o: lexing.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h main.p.o: main.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/sys.h -main.p.p.o: main.p.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ @@ -1227,27 +635,12 @@ major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h -major_gc.p.p.o: major_gc.p.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ ../byterun/reverse.h -md5.p.p.o: md5.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ @@ -1255,13 +648,6 @@ memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/signals.h -memory.p.p.o: memory.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ @@ -1279,37 +665,18 @@ minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ ../byterun/weak.h -minor_gc.p.p.o: minor_gc.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h -misc.p.p.o: misc.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h -natdynlink.p.p.o: natdynlink.p.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - 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 \ @@ -1317,33 +684,16 @@ obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h -obj.p.p.o: obj.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/alloc.h -parsing.p.p.o: parsing.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/printexc.h -printexc.p.p.o: printexc.p.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ @@ -1351,13 +701,6 @@ roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h stack.h ../byterun/roots.h -roots.p.p.o: roots.p.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ @@ -1366,48 +709,24 @@ signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ ../byterun/sys.h -signals.p.p.o: signals.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ signals_osdep.h stack.h -signals_asm.p.p.o: signals_asm.p.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/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 -startup.p.p.o: startup.p.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h + ../byterun/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 str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h -str.p.p.o: str.p.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -1415,38 +734,17 @@ sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -sys.p.p.o: sys.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.p.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ ../byterun/io.h ../byterun/mlvalues.h -terminfo.p.p.o: terminfo.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h unix.p.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/osdeps.h -unix.p.p.o: unix.p.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h -weak.p.p.o: weak.p.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/mlvalues.h diff --git a/asmrun/Makefile b/asmrun/Makefile index 2ccfa880dc..4d7e6552b8 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -26,7 +26,8 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o + compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o \ + meta.o dynlink.o ASMOBJS=$(ARCH).o diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 81e2890143..3cefe2d380 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -24,7 +24,7 @@ COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ - backtrace.$(O) natdynlink.$(O) debugger.$(O) + backtrace.$(O) natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 715e796bcb..70dbd80c32 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -22,7 +22,7 @@ #if defined(SYS_macosx) -#define LBL(x) L##x +#define LBL(x) L##x #define G(r) _##r #define GREL(r) _##r@GOTPCREL #define GCALL(r) _##r @@ -35,8 +35,8 @@ name: #elif defined(SYS_mingw64) - -#define LBL(x) .L##x + +#define LBL(x) .L##x #define G(r) r #undef GREL #define GCALL(r) r @@ -50,7 +50,7 @@ #else -#define LBL(x) .L##x +#define LBL(x) .L##x #define G(r) r #define GREL(r) r@GOTPCREL #define GCALL(r) r@PLT @@ -74,7 +74,7 @@ #define CFI_ENDPROC #define CFI_ADJUST(n) #endif - + #if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ @@ -119,7 +119,7 @@ popq %r11 #else - + /* Non-PIC operations on global variables. Slightly faster. */ #define STORE_VAR(srcreg,dstlabel) \ @@ -148,10 +148,10 @@ #endif -/* Save and restore all callee-save registers on stack. +/* Save and restore all callee-save registers on stack. Keep the stack 16-aligned. */ -#if defined(SYS_mingw64) +#if defined(SYS_mingw64) /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ @@ -219,11 +219,11 @@ popq %rbp; \ popq %rbx -#endif +#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 PREPARE_FOR_C_CALL subq $32, %rsp # define CLEANUP_AFTER_C_CALL addq $32, %rsp #else # define PREPARE_FOR_C_CALL @@ -389,6 +389,7 @@ LBL(caml_c_call): popq %r12 STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) + pushq %r12 #ifndef SYS_mingw64 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ @@ -402,12 +403,7 @@ LBL(caml_c_call): /* 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) - /* Return to caller */ - pushq %r12 - ret + jmp *%rax /* Start the OCaml program */ diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index 9de81b018f..8625c545c8 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -17,6 +17,7 @@ #include "stack.h" #include "callback.h" #include "alloc.h" +#include "intext.h" #include "natdynlink.h" #include "osdeps.h" #include "fail.h" @@ -74,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; @@ -94,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/startup.c b/asmrun/startup.c index cb54a52c85..a04fa84fcb 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -25,6 +25,7 @@ #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" +#include "intext.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" @@ -49,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); @@ -74,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/.ignore b/boot/.ignore index a0a2356c9a..8165156d9a 100644 --- a/boot/.ignore +++ b/boot/.ignore @@ -1,6 +1,8 @@ Saved ocamlrun +ocamlrun.exe ocamlyacc +ocamlyacc.exe camlheader myocamlbuild myocamlbuild.native diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex ba9dfe38ee..34ddcf361d 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex f01f099784..5854d1d412 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex ddf01532f2..a0926c0d1f 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/build/camlp4-bootstrap-recipe.txt b/build/camlp4-bootstrap-recipe.txt index 264d63551e..1206038010 100644 --- a/build/camlp4-bootstrap-recipe.txt +++ b/build/camlp4-bootstrap-recipe.txt @@ -2,6 +2,7 @@ make clean ./build/distclean.sh ./configure -prefix `pwd`/_install + (cd otherlibs/labltk/browser; make help.ml) ./build/fastworld.sh # Go to "Bootstrap camlp4" @@ -121,7 +122,7 @@ In Camlp4/Printers/OCaml.ml: | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" + pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" o#ident i o#reset_semi#expr e And at the end of #simple_expr: <:expr< let open $_$ in $_$ >> diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index c1021d53ed..6daa582e36 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -466,6 +466,7 @@ let link_bytecode_as_c ppf tolink outfile = close_out outchan with x -> close_out outchan; + remove_file outfile; raise x end; if !Clflags.debug then diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 53bb003972..ac6ce57e58 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -40,6 +40,9 @@ let names_of_opened_dlls = ref ([] : string list) let add_path dirs = search_path := dirs @ !search_path +let remove_path dirs = + search_path := List.filter (fun d -> not (List.mem d dirs)) !search_path + (* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *) let extract_dll_name file = diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index a4841d3d31..645db75a84 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -46,6 +46,9 @@ val synchronize_primitive: int -> dll_address -> unit (* Add the given directories at the head of the search path for DLLs *) val add_path: string list -> unit +(* Remove the given directories from the search path for DLLs *) +val remove_path: string list -> unit + (* Initialization for separate compilation. Initialize the DLL search path to the directories given in the environment variable CAML_LD_LIBRARY_PATH, plus contents of ld.conf file diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index a08b3664a0..aafadfc21f 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -124,7 +124,7 @@ let filter_matrix matcher pss = let rec filter_rec = function | (p::ps)::rem -> begin match p.pat_desc with - | Tpat_alias (p,_) -> + | Tpat_alias (p,_,_) -> filter_rec ((p::ps)::rem) | Tpat_var _ -> filter_rec ((omega::ps)::rem) @@ -162,9 +162,9 @@ let make_default matcher env = let ctx_matcher p = let p = normalize_pat p in match p.pat_desc with - | Tpat_construct (cstr,omegas) -> + | Tpat_construct (_, _, cstr,omegas,_) -> (fun q rem -> match q.pat_desc with - | Tpat_construct (cstr',args) when cstr.cstr_tag=cstr'.cstr_tag -> + | Tpat_construct (_, _, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag -> p,args @ rem | Tpat_any -> p,omegas @ rem | _ -> raise NoMatch) @@ -197,12 +197,12 @@ let ctx_matcher p = (fun q rem -> match q.pat_desc with | Tpat_tuple args -> p,args @ rem | _ -> p, omegas @ rem) - | Tpat_record l -> (* Records are normalized *) + | Tpat_record (l,_) -> (* Records are normalized *) (fun q rem -> match q.pat_desc with - | Tpat_record l' -> + | Tpat_record (l',_) -> let l' = all_record_args l' in - p, List.fold_right (fun (_,p) r -> p::r) l' rem - | _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem) + p, List.fold_right (fun (_, _, _,p) r -> p::r) l' rem + | _ -> p,List.fold_right (fun (_, _, _,p) r -> p::r) l rem) | Tpat_lazy omega -> (fun q rem -> match q.pat_desc with | Tpat_lazy arg -> p, (arg::rem) @@ -221,7 +221,7 @@ let filter_ctx q ctx = begin match p.pat_desc with | Tpat_or (p1,p2,_) -> filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) - | Tpat_alias (p,_) -> + | Tpat_alias (p,_,_) -> filter_rec ({l with right=p::ps}::rem) | Tpat_var _ -> filter_rec ({l with right=omega::ps}::rem) @@ -507,11 +507,11 @@ exception Var of pattern let simplify_or p = let rec simpl_rec p = match p with | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) - | {pat_desc = Tpat_alias (q,id)} -> + | {pat_desc = Tpat_alias (q,id,s)} -> begin try - {p with pat_desc = Tpat_alias (simpl_rec q,id)} + {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} with - | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id)}) + | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) end | {pat_desc = Tpat_or (p1,p2,o)} -> let q1 = simpl_rec p1 in @@ -521,9 +521,9 @@ let simplify_or p = with | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) end - | {pat_desc = Tpat_record lbls} -> + | {pat_desc = Tpat_record (lbls,closed)} -> let all_lbls = all_record_args lbls in - {p with pat_desc=Tpat_record all_lbls} + {p with pat_desc=Tpat_record (all_lbls, closed)} | _ -> p in try simpl_rec p @@ -537,19 +537,19 @@ let rec simplify_cases args cls = match args with | [] -> [] | ((pat :: patl, action) as cl) :: rem -> begin match pat.pat_desc with - | Tpat_var id -> + | Tpat_var (id, _) -> (omega :: patl, bind Alias id arg action) :: simplify rem | Tpat_any -> cl :: simplify rem - | Tpat_alias(p, id) -> + | Tpat_alias(p, id,_) -> simplify ((p :: patl, bind Alias id arg action) :: rem) - | Tpat_record [] -> + | Tpat_record ([],_) -> (omega :: patl, action):: simplify rem - | Tpat_record lbls -> + | Tpat_record (lbls, closed) -> let all_lbls = all_record_args lbls in - let full_pat = {pat with pat_desc=Tpat_record all_lbls} in + let full_pat = {pat with pat_desc=Tpat_record (all_lbls, closed)} in (full_pat::patl,action):: simplify rem | Tpat_or _ -> @@ -574,7 +574,7 @@ let rec simplify_cases args cls = match args with let rec what_is_cases cases = match cases with | ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem -| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_))}::_),_)::_ +| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ -> assert false (* applies to simplified matchings only *) | (p::_,_)::_ -> p | [] -> omega @@ -606,16 +606,16 @@ let default_compat p def = (* Or-pattern expansion, variables are a complication w.r.t. the article *) let rec extract_vars r p = match p.pat_desc with -| Tpat_var id -> IdentSet.add id r -| Tpat_alias (p, id) -> +| Tpat_var (id, _) -> IdentSet.add id r +| Tpat_alias (p, id,_ ) -> extract_vars (IdentSet.add id r) p | Tpat_tuple pats -> List.fold_left extract_vars r pats -| Tpat_record lpats -> +| Tpat_record (lpats,_) -> List.fold_left - (fun r (_,p) -> extract_vars r p) + (fun r (_, _, _, p) -> extract_vars r p) r lpats -| Tpat_construct (_,pats) -> +| Tpat_construct (_, _, _, pats,_) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats @@ -643,9 +643,9 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function arg patl mk_action (explode_or_pat arg patl mk_action rem vars aliases p2) vars aliases p1 - | {pat_desc = Tpat_alias (p,id)} -> + | {pat_desc = Tpat_alias (p,id, _)} -> explode_or_pat arg patl mk_action rem vars (id::aliases) p - | {pat_desc = Tpat_var x} -> + | {pat_desc = Tpat_var (x, _)} -> let env = mk_alpha_env arg (x::aliases) vars in (omega::patl,mk_action (List.map snd env))::rem | p -> @@ -665,7 +665,7 @@ let group_constant = function | _ -> false and group_constructor = function - | {pat_desc = Tpat_construct (_, _)} -> true + | {pat_desc = Tpat_construct (_, _, _, _,_)} -> true | _ -> false and group_variant = function @@ -695,7 +695,7 @@ and group_lazy = function let get_group p = match p.pat_desc with | Tpat_any -> group_var | Tpat_constant _ -> group_constant -| Tpat_construct (_, _) -> group_constructor +| Tpat_construct (_, _, _, _, _) -> group_constructor | Tpat_tuple _ -> group_tuple | Tpat_record _ -> group_record | Tpat_array _ -> group_array @@ -1129,15 +1129,15 @@ let make_field_args binding_kind arg first_pos last_pos argl = in make_args first_pos let get_key_constr = function - | {pat_desc=Tpat_construct (cstr,_)} -> cstr.cstr_tag + | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr.cstr_tag | _ -> assert false let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_,args)} -> args @ rem +| {pat_desc=Tpat_construct (_, _, _, args, _)} -> args @ rem | _ -> assert false let pat_as_constr = function - | {pat_desc=Tpat_construct (cstr,_)} -> cstr + | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr | _ -> fatal_error "Matching.pat_as_constr" @@ -1151,7 +1151,7 @@ let matcher_constr cstr = match cstr.cstr_arity with with | NoMatch -> matcher_rec p2 rem end - | Tpat_construct (cstr1, []) when cstr.cstr_tag = cstr1.cstr_tag -> + | Tpat_construct (_, _, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag -> rem | Tpat_any -> rem | _ -> raise NoMatch in @@ -1172,7 +1172,7 @@ pat_desc = Tpat_or (a1, a2, None)}:: rem | _, _ -> assert false end - | Tpat_construct (cstr1, [arg]) when cstr.cstr_tag = cstr1.cstr_tag -> + | Tpat_construct (_, _, cstr1, [arg],_) when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem | Tpat_any -> omega::rem | _ -> raise NoMatch in @@ -1180,7 +1180,7 @@ pat_desc = Tpat_or (a1, a2, None)}:: | _ -> fun q rem -> match q.pat_desc with | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (cstr1, args) + | Tpat_construct (_, _, cstr1, args,_) when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem | _ -> raise NoMatch @@ -1446,13 +1446,13 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = let patv = Array.create num_fields omega in - List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + List.iter (fun (_, _, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv let get_args_record num_fields p rem = match p with | {pat_desc=Tpat_any} -> record_matching_line num_fields [] @ rem -| {pat_desc=Tpat_record lbl_pat_list} -> +| {pat_desc=Tpat_record (lbl_pat_list,_)} -> record_matching_line num_fields lbl_pat_list @ rem | _ -> assert false @@ -1846,7 +1846,7 @@ let rec extract_pat seen k p = match p.pat_desc with | Tpat_or (p1,p2,_) -> let k1,seen1 = extract_pat seen k p1 in extract_pat seen1 k1 p2 -| Tpat_alias (p,_) -> +| Tpat_alias (p,_,_) -> extract_pat seen k p | Tpat_var _|Tpat_any -> raise All @@ -2367,8 +2367,8 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = m let rec name_pattern default = function (pat :: patl, action) :: rem -> begin match pat.pat_desc with - Tpat_var id -> id - | Tpat_alias(p, id) -> id + Tpat_var (id, _) -> id + | Tpat_alias(p, id, _) -> id | _ -> name_pattern default rem end | _ -> Ident.create default @@ -2438,7 +2438,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with compile_no_test (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_record ((lbl,_)::_) -> + | Tpat_record ((_, _, lbl,_)::_,_) -> compile_no_test (divide_record lbl.lbl_all (normalize_pat pat)) ctx_combine repr partial ctx pm @@ -2448,7 +2448,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with divide_constant (combine_constant arg cst partial) ctx pm - | Tpat_construct (cstr, _) -> + | Tpat_construct (_, _, cstr, _, _) -> compile_test (compile_match repr partial) partial divide_constructor (combine_constructor arg pat cstr partial) @@ -2594,7 +2594,7 @@ let rec flatten_pat_line size p k = match p.pat_desc with | Tpat_any -> omegas size::k | Tpat_tuple args -> args::k | Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) -| Tpat_alias (p,_) -> (* Note: if this 'as' pat is here, then this is a useless +| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a useless binding, solves PR #3780 *) flatten_pat_line size p k | _ -> fatal_error "Matching.flatten_pat_line" diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 4e5f1475c9..0785316f60 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -126,7 +126,7 @@ let output_primitive_table outchan = fprintf outchan " %s,\n" prim.(i) done; fprintf outchan " (primitive) 0 };\n"; - fprintf outchan "char * caml_names_of_builtin_cprim[] = {\n"; + fprintf outchan "const char * caml_names_of_builtin_cprim[] = {\n"; for i = 0 to Array.length prim - 1 do fprintf outchan " \"%s\",\n" prim.(i) done; diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index d592484fd4..a4bdd480fd 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -114,7 +114,7 @@ let create_object cl obj init = let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with - Tclass_ident path -> + Tcl_ident ( path, _, _) -> let obj_init = Ident.create "obj_init" in let envs, inh_init = inh_init in let env = @@ -123,27 +123,27 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = in ((envs, (obj_init, path)::inh_init), mkappl(Lvar obj_init, env @ [obj])) - | Tclass_structure str -> + | Tcl_structure str -> create_object cl_table obj (fun obj -> let (inh_init, obj_init, has_init) = List.fold_right (fun field (inh_init, obj_init, has_init) -> - match field with - Cf_inher (cl, _, _) -> + match field.cf_desc with + Tcf_inher (_, cl, _, _, _) -> let (inh_init, obj_init') = build_object_init cl_table (Lvar obj) [] inh_init (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) - | Cf_val (_, id, Some exp, _) -> + | Tcf_val (_, _, _, id, Tcfk_concrete exp, _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Cf_meth _ | Cf_val _ -> + | Tcf_meth _ | Tcf_val _ | Tcf_constr _ -> (inh_init, obj_init, has_init) - | Cf_init _ -> + | Tcf_init _ -> (inh_init, obj_init, true) ) - str.cl_field + str.cstr_fields (inh_init, obj_init obj, false) in (inh_init, @@ -152,7 +152,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = lsequence (Lifused (id, set_inst_var obj id expr)) rem) params obj_init, has_init)) - | Tclass_fun (pat, vals, cl, partial) -> + | Tcl_fun (_, pat, vals, cl, partial) -> + let vals = List.map (fun (id, _, e) -> id,e) vals in let (inh_init, obj_init) = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in @@ -168,22 +169,24 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = Lfunction (Curried, params, rem) -> build params rem | rem -> build [] rem end) - | Tclass_apply (cl, oexprs) -> + | Tcl_apply (cl, oexprs) -> let (inh_init, obj_init) = build_object_init cl_table obj params inh_init obj_init cl in (inh_init, transl_apply obj_init oexprs Location.none) - | Tclass_let (rec_flag, defs, vals, cl) -> + | Tcl_let (rec_flag, defs, vals, cl) -> + let vals = List.map (fun (id, _, e) -> id,e) vals in let (inh_init, obj_init) = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tclass_constraint (cl, vals, pub_meths, concr_meths) -> + | Tcl_constraint (cl, _, vals, pub_meths, concr_meths) -> build_object_init cl_table obj params inh_init obj_init cl let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = match cl.cl_desc with - Tclass_let (rec_flag, defs, vals, cl) -> + Tcl_let (rec_flag, defs, vals, cl) -> + let vals = List.map (fun (id, _, e) -> id,e) vals in build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids | _ -> let self = Ident.create "self" in @@ -232,8 +235,8 @@ let output_methods tbl methods lam = let rec ignore_cstrs cl = match cl.cl_desc with - Tclass_constraint (cl, _, _, _) -> ignore_cstrs cl - | Tclass_apply (cl, _) -> ignore_cstrs cl + Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl + | Tcl_apply (cl, _) -> ignore_cstrs cl | _ -> cl let rec index a = function @@ -241,11 +244,11 @@ let rec index a = function | b :: l -> if b = a then 0 else 1 + index a l -let bind_id_as_val (id, _) = ("", id) +let bind_id_as_val (id, _, _) = ("", id) let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with - Tclass_ident path -> + Tcl_ident ( path, _, _) -> begin match inh_init with (obj_init, path')::inh_init -> let lpath = transl_path path in @@ -257,23 +260,27 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = | _ -> assert false end - | Tclass_structure str -> + | Tcl_structure str -> let cl_init = bind_super cla super cl_init in let (inh_init, cl_init, methods, values) = List.fold_right (fun field (inh_init, cl_init, methods, values) -> - match field with - Cf_inher (cl, vals, meths) -> + match field.cf_desc with + Tcf_inher (_, cl, _, vals, meths) -> let cl_init = output_methods cla methods cl_init in let inh_init, cl_init = build_class_init cla false - (vals, meths_super cla str.cl_meths meths) + (vals, meths_super cla str.cstr_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) - | Cf_val (name, id, exp, over) -> + | Tcf_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) -> + | Tcf_meth (_, _, _, Tcfk_virtual _, _) + | Tcf_constr _ + -> + (inh_init, cl_init, methods, values) + | Tcf_meth (name, _, _, Tcfk_concrete exp, over) -> let met_code = msubst true (transl_exp exp) in let met_code = if !Clflags.native_code && List.length met_code = 1 then @@ -283,34 +290,34 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = else met_code in (inh_init, cl_init, - Lvar (Meths.find name str.cl_meths) :: met_code @ methods, + Lvar (Meths.find name str.cstr_meths) :: met_code @ methods, values) - | Cf_init exp -> + | Tcf_init exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), methods, values)) - str.cl_field + str.cstr_fields (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) - | Tclass_fun (pat, vals, cl, _) -> + (inh_init, bind_methods cla str.cstr_meths values cl_init) + | Tcl_fun (_, pat, vals, cl, _) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tclass_apply (cl, exprs) -> + | Tcl_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl - | Tclass_let (rec_flag, defs, vals, cl) -> + | Tcl_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tclass_constraint (cl, vals, meths, concr_meths) -> + | Tcl_constraint (cl, _, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in let concr_meths = Concr.elements concr_meths in @@ -321,7 +328,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = transl_meth_list concr_meths] in let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with - Tclass_ident path, (obj_init, path')::inh_init -> + Tcl_ident (path, _, _), (obj_init, path')::inh_init -> assert (Path.same path path'); let lpath = transl_path path in let inh = Ident.create "inh" @@ -358,7 +365,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let rec build_class_lets cl = match cl.cl_desc with - Tclass_let (rec_flag, defs, vals, cl) -> + Tcl_let (rec_flag, defs, vals, cl) -> let env, wrap = build_class_lets cl in (env, fun x -> Translcore.transl_let rec_flag defs (wrap x)) | _ -> @@ -366,13 +373,13 @@ let rec build_class_lets cl = let rec get_class_meths cl = match cl.cl_desc with - Tclass_structure cl -> - Meths.fold (fun _ -> IdentSet.add) cl.cl_meths IdentSet.empty - | Tclass_ident _ -> IdentSet.empty - | Tclass_fun (_, _, cl, _) - | Tclass_let (_, _, _, cl) - | Tclass_apply (cl, _) - | Tclass_constraint (cl, _, _, _) -> get_class_meths cl + Tcl_structure cl -> + Meths.fold (fun _ -> IdentSet.add) cl.cstr_meths IdentSet.empty + | Tcl_ident _ -> IdentSet.empty + | Tcl_fun (_, _, _, cl, _) + | Tcl_let (_, _, _, cl) + | Tcl_apply (cl, _) + | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl (* XXX Il devrait etre peu couteux d'ecrire des classes : @@ -380,13 +387,13 @@ let rec get_class_meths cl = *) let rec transl_class_rebind obj_init cl vf = match cl.cl_desc with - Tclass_ident path -> + Tcl_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) -> + | Tcl_fun (_, pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = let param = name_pattern "param" [pat, ()] in @@ -399,18 +406,18 @@ let rec transl_class_rebind obj_init cl vf = match obj_init with Lfunction (Curried, params, rem) -> build params rem | rem -> build [] rem) - | Tclass_apply (cl, oexprs) -> + | Tcl_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs Location.none) - | Tclass_let (rec_flag, defs, vals, cl) -> + | Tcl_let (rec_flag, defs, vals, cl) -> 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', _, _, _) -> + | Tcl_structure _ -> raise Exit + | Tcl_constraint (cl', _, _, _, _) -> 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 + Cty_constr(path', _, _) when Path.same path path' -> () + | Cty_fun (_, _, cty) -> check_constraint cty | _ -> raise Exit in check_constraint cl.cl_type; @@ -418,7 +425,7 @@ let rec transl_class_rebind obj_init cl vf = let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with - Tclass_let (rec_flag, defs, vals, cl) -> + Tcl_let (rec_flag, defs, vals, cl) -> let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> @@ -581,7 +588,7 @@ let prerr_ids msg ids = let names = List.map Ident.unique_toplevel_name ids in prerr_endline (String.concat " " (msg :: names)) -let transl_class ids cl_id arity pub_meths cl vflag = +let transl_class ids cl_id pub_meths cl vflag = (* First check if it is not only a rebind *) let rebind = transl_class_rebind ids cl vflag in if rebind <> lambda_unit then rebind else @@ -791,12 +798,20 @@ let transl_class ids cl_id arity pub_meths cl vflag = ))))) (* Wrapper for class compilation *) +(* + let cl_id = ci.ci_id_class in +(* TODO: cl_id is used somewhere else as typesharp ? *) + let _arity = List.length (fst ci.ci_params) in + let pub_meths = m in + let cl = ci.ci_expr in + let vflag = vf in +*) -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_class ids id pub_meths cl vf = + oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf let () = - transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete) + transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete) (* Error report *) diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index 7a5d6d1437..34dd7e671d 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -17,7 +17,7 @@ open Lambda val transl_class : Ident.t list -> Ident.t -> - int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;; + string list -> class_expr -> Asttypes.virtual_flag -> lambda;; type error = Illegal_class_expr | Tags of string * string diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 6f543ab929..ea0aa21a83 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -294,10 +294,10 @@ let transl_prim loc prim args = simplify_constant_constructor) = Hashtbl.find comparisons_table prim_name in begin match args with - [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] + [arg1; {exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}] when simplify_constant_constructor -> intcomp - | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] + | [{exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}; arg2] when simplify_constant_constructor -> intcomp | [arg1; {exp_desc = Texp_variant(_, None)}] @@ -489,7 +489,7 @@ let extract_float = function (*> JOCAML *) let name_join_pattern default p = match p.pat_desc with - | Tpat_var id | Tpat_alias (_,id) -> id + | Tpat_var (id,_) | Tpat_alias (_,id,_) -> id | _ -> Ident.create default (*< JOCAML *) @@ -497,17 +497,17 @@ let rec name_pattern default = function [] -> Ident.create default | (p, e) :: rem -> match p.pat_desc with - Tpat_var id -> id - | Tpat_alias(p, id) -> id + Tpat_var (id, _) -> id + | Tpat_alias(p, id, _) -> id | _ -> name_pattern default rem (* Push the default values under the functional abstractions *) let rec push_defaults loc bindings pat_expr_list partial = match pat_expr_list with - [pat, ({exp_desc = Texp_function(pl,partial)} as exp)] -> + [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] -> let pl = push_defaults exp.exp_loc bindings pl partial in - [pat, {exp with exp_desc = Texp_function(pl, partial)}] + [pat, {exp with exp_desc = Texp_function(l, pl, partial)}] | [pat, {exp_desc = Texp_let (Default, cases, ({exp_desc = Texp_function _} as e2))}] -> push_defaults loc (cases :: bindings) [pat, e2] partial @@ -521,18 +521,19 @@ let rec push_defaults loc bindings pat_expr_list partial = [pat, exp] | (pat, exp) :: _ when bindings <> [] -> let param = name_pattern "param" pat_expr_list in + let name = Ident.name param in let exp = { exp with exp_loc = loc; exp_desc = Texp_match ({exp with exp_type = pat.pat_type; exp_desc = - Texp_ident (Path.Pident param, + Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), {val_type = pat.pat_type; val_kind = Val_reg; - val_loc = Location.none; + Types.val_loc = Location.none; })}, pat_expr_list, partial) } in push_defaults loc bindings - [{pat with pat_desc = Tpat_var param}, exp] Total + [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total | _ -> pat_expr_list @@ -613,7 +614,7 @@ let rec transl_exp e = and transl_exp0 e = match e.exp_desc with - Texp_ident(path, {val_kind = Val_prim p}) -> + Texp_ident(path, _, {val_kind = Val_prim p}) -> let public_send = p.prim_name = "%send" in if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in @@ -626,10 +627,10 @@ and transl_exp0 e = Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc)) else transl_primitive p - | Texp_ident(path, {val_kind = Val_anc _}) -> + | Texp_ident(path, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident - (path, + (path, _, {val_kind = Val_reg|Val_self _|Val_channel (_,_)|Val_alone _}) -> transl_path path | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" @@ -643,7 +644,7 @@ and transl_exp0 e = do_transl_def d (transl_exp body) | Texp_loc (d,body) -> assert false (*>JOCAML*) - | Texp_function (pat_expr_list, partial) -> + | Texp_function (_, pat_expr_list, partial) -> let ((kind, params), body) = event_function e (function repr -> @@ -653,21 +654,21 @@ and transl_exp0 e = Lfunction(kind, params, body) (* two small optimizations *) | Texp_apply - ({exp_desc = Texp_ident(path, {val_kind = Val_alone id})}, - [Some arg,_]) + ({exp_desc = Texp_ident(path, _, {val_kind = Val_alone id})}, + [_,Some arg,_]) -> Lapply (Lvar id,[transl_exp arg],e.exp_loc) | Texp_apply - ({exp_desc = Texp_ident(path, {val_kind = Val_channel (auto,idx)})}, - [Some arg,_]) + ({exp_desc = Texp_ident(path, _, {val_kind = Val_channel (auto,idx)})}, + [_,Some arg,_]) -> Transljoin.local_send_sync auto idx (transl_exp arg) e.exp_loc (*<JOCAML*) - | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs) + | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs) when List.length oargs >= p.prim_arity - && List.for_all (fun (arg,_) -> arg <> None) oargs -> + && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> let args, args' = cut p.prim_arity oargs in let wrap f = if args' = [] @@ -676,7 +677,7 @@ and transl_exp0 e = in let wrap0 f = if args' = [] then f else wrap f in - let args = List.map (function Some x, _ -> x | _ -> assert false) args in + let args = List.map (function _, Some x, _ -> x | _ -> assert false) args in let argl = transl_list transl_exp args in let public_send = p.prim_name = "%send" || not !Clflags.native_code && p.prim_name = "%sendcache"in @@ -727,7 +728,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(0, Immutable), ll) end - | Texp_construct(cstr, args) -> + | Texp_construct(_, _, cstr, args, _) -> let ll = transl_list transl_exp args in begin match cstr.cstr_tag with Cstr_constant n -> @@ -754,17 +755,17 @@ and transl_exp0 e = Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_int tag)); lam]) end - | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> + | Texp_record ((_, _, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" - | Texp_field(arg, lbl) -> + | Texp_field(arg, _, _, lbl) -> let access = match lbl.lbl_repres with Record_regular -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos in Lprim(access, [transl_exp arg]) - | Texp_setfield(arg, lbl, newval) -> + | Texp_setfield(arg, _, _, lbl, newval) -> let access = match lbl.lbl_repres with Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) @@ -801,14 +802,15 @@ and transl_exp0 e = Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) | Texp_while(cond, body) -> Lwhile(transl_exp cond, event_before body (transl_exp body)) - | Texp_for(param, low, high, dir, body) -> + | Texp_for(param, _, low, high, dir, body) -> Lfor(param, transl_exp low, transl_exp high, dir, event_before body (transl_exp body)) | Texp_when(cond, body) -> event_before cond (Lifthenelse(transl_exp cond, event_before body (transl_exp body), staticfail)) - | Texp_send(expr, met) -> + | Texp_send(_, _, Some exp) -> transl_exp exp + | Texp_send(expr, met, None) -> let obj = transl_exp expr in let lam = match met with @@ -819,11 +821,11 @@ and transl_exp0 e = Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam - | Texp_new (cl, _) -> + | Texp_new (cl, _, _) -> Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) - | Texp_instvar(path_self, path) -> + | Texp_instvar(path_self, path, _) -> Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) - | Texp_setinstvar(path_self, path, expr) -> + | Texp_setinstvar(path_self, path, _, expr) -> transl_setinstvar (transl_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in @@ -831,11 +833,11 @@ and transl_exp0 e = Lapply(Translobj.oo_prim "copy", [transl_path path_self], Location.none), List.fold_right - (fun (path, expr) rem -> + (fun (path, _, expr) rem -> Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) modifs (Lvar cpy)) - | Texp_letmodule(id, modl, body) -> + | Texp_letmodule(id, _, modl, body) -> Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl @@ -853,12 +855,12 @@ and transl_exp0 e = | Texp_constant ( Const_int _ | Const_char _ | Const_string _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) - | Texp_function(_, _) - | Texp_construct ({cstr_arity = 0}, _) + | Texp_function(_, _, _) + | Texp_construct (_, _, {cstr_arity = 0}, _, _) -> transl_exp e | Texp_constant(Const_float _) -> Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - | Texp_ident(_, _) -> (* according to the type *) + | Texp_ident(_, _, _) -> (* according to the type *) begin match e.exp_type.desc with | Tproc _ -> assert false (* By typing *) (* the following may represent a float/forward/lazy: need a @@ -895,12 +897,13 @@ and transl_exp0 e = let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) end - | Texp_object (cs, cty, meths) -> + | Texp_object (cs, meths) -> + let cty = cs.cstr_type in let cl = Ident.create "class" in !transl_object cl meths - { cl_desc = Tclass_structure cs; + { cl_desc = Tcl_structure cs; cl_loc = e.exp_loc; - cl_type = Tcty_signature cty; + cl_type = Cty_signature cty; cl_env = e.exp_env } (*> JOCAML *) | Texp_spawn (e) -> transl_spawn e @@ -957,7 +960,7 @@ and transl_proc die sync p = match p.exp_desc with None (Transljoin.reply_handler sync p transl_exp arg) (transl_cases (transl_proc die sync) pat_expr_list) partial -| Texp_for(param, low, high, dir, body) -> +| Texp_for(param, _, low, high, dir, body) -> assert (sync = None) ; let lam_low = transl_exp low and lam_high = transl_exp high in @@ -986,13 +989,13 @@ and transl_proc die sync p = match p.exp_desc with end | Texp_asyncsend (_,_) | Texp_reply (_,_) | Texp_null -> transl_simple_proc die sync p -| Texp_spawn _|Texp_object (_, _, _)|Texp_lazy _|Texp_assert _| - Texp_letmodule (_, _, _)|Texp_override (_, _)|Texp_setinstvar (_, _, _)| - Texp_instvar (_, _)|Texp_new (_, _)|Texp_send (_, _)| - Texp_while (_, _)|Texp_array _| - Texp_setfield (_, _, _)|Texp_field (_, _)|Texp_record (_, _)| - Texp_variant (_, _)|Texp_construct (_, _)|Texp_tuple _|Texp_try (_, _)| - Texp_apply (_, _)|Texp_function (_, _)|Texp_constant _|Texp_ident (_, _)| +| Texp_spawn _|Texp_object _|Texp_lazy _|Texp_assert _| + Texp_letmodule _|Texp_override _|Texp_setinstvar _| + Texp_instvar _|Texp_new _|Texp_send _| + Texp_while _|Texp_array _| + Texp_setfield _|Texp_field _|Texp_record _| + Texp_variant _|Texp_construct _|Texp_tuple _|Texp_try _| + Texp_apply _|Texp_function _|Texp_constant _|Texp_ident _| Texp_assertfalse | Texp_pack _ -> Location.print_error Format.err_formatter p.exp_loc ; @@ -1036,7 +1039,7 @@ and transl_simple_proc die sync p = match p.exp_desc with (transl_exp arg) (transl_cases (transl_simple_proc die sync) pat_expr_list) partial -| Texp_for(param, low, high, dir, body) -> +| Texp_for(param, _, low, high, dir, body) -> assert (sync=None) ; Lfor(param, transl_exp low, transl_exp high, dir, event_before body (transl_spawn body)) (* loop body should not fail *) @@ -1046,12 +1049,12 @@ and transl_simple_proc die sync p = match p.exp_desc with (transl_simple_proc false sync p1) (transl_simple_proc die sync p2) | Texp_asyncsend - ({exp_desc=Texp_ident (_,{val_kind=Val_channel (auto,num)})},e2) -> + ({exp_desc=Texp_ident (_,_,{val_kind=Val_channel (auto,num)})},e2) -> (if die then Transljoin.local_tail_send_async else Transljoin.local_send_async) auto num (transl_exp e2) p.exp_loc | Texp_asyncsend - ({exp_desc=Texp_ident (_,{val_kind=Val_alone (guard)})},e2) -> + ({exp_desc=Texp_ident (_,_,{val_kind=Val_alone (guard)})},e2) -> (if die then Transljoin.local_tail_send_alone else Transljoin.local_send_alone) guard (transl_exp e2) p.exp_loc @@ -1068,13 +1071,13 @@ and transl_simple_proc die sync p = match p.exp_desc with end | Texp_null -> lambda_unit (* Plain expression are errors *) -| Texp_spawn _|Texp_object (_, _, _)|Texp_lazy _|Texp_assert _| - Texp_letmodule (_, _, _)|Texp_override (_, _)|Texp_setinstvar (_, _, _)| - Texp_instvar (_, _)|Texp_new (_, _)|Texp_send (_, _)| - Texp_while (_, _)|Texp_array _| - Texp_setfield (_, _, _)|Texp_field (_, _)|Texp_record (_, _)| - Texp_variant (_, _)|Texp_construct (_, _)|Texp_tuple _|Texp_try (_, _)| - Texp_apply (_, _)|Texp_function (_, _)|Texp_constant _|Texp_ident (_, _)| +| Texp_spawn _|Texp_object _|Texp_lazy _|Texp_assert _| + Texp_letmodule _|Texp_override _|Texp_setinstvar _| + Texp_instvar _|Texp_new _|Texp_send _| + Texp_while _|Texp_array _| + Texp_setfield _|Texp_field _|Texp_record _| + Texp_variant _|Texp_construct _|Texp_tuple _|Texp_try _| + Texp_apply _|Texp_function _|Texp_constant _|Texp_ident _| Texp_assertfalse|Texp_pack _ -> assert false @@ -1266,11 +1269,11 @@ and transl_apply lam sargs loc = | [] -> lapply lam (List.rev_map fst args) in - build_apply lam [] (List.map (fun (x,o) -> may_map transl_exp x, o) sargs) + build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs) and transl_function loc untuplify_fn repr partial pat_expr_list = match pat_expr_list with - [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] + [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)] when Parmatch.fluid pat -> let param = name_pattern "param" pat_expr_list in let ((_, params), body) = @@ -1314,10 +1317,9 @@ and transl_let reply_handler transl_exp rec_flag pat_expr_list body = | Recursive -> let idlist = List.map - (fun (pat, expr) -> - match pat.pat_desc with - Tpat_var id -> id - | Tpat_alias ({pat_desc=Tpat_any}, id) -> id + (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 = @@ -1410,11 +1412,11 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = done end; List.iter - (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) + (fun (_, _, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) lbl_expr_list; let ll = Array.to_list lv in let mut = - if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list + if List.exists (fun (_, _, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list then Mutable else Immutable in let lam = @@ -1439,7 +1441,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = (* If you change anything here, you will likely have to change [check_recursive_recordwith] in this file. *) let copy_id = Ident.create "newrecord" in - let rec update_field (lbl, expr) cont = + let rec update_field (_, _, lbl, expr) cont = let upd = match lbl.lbl_repres with Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 0bddfc6d08..604edea3d8 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -23,7 +23,7 @@ open Lambda val name_pattern: string -> (pattern * 'a) list -> Ident.t val transl_exp: expression -> lambda -val transl_apply: lambda -> (expression option * optional) list +val transl_apply: lambda -> (label * expression option * optional) list -> Location.t -> lambda val transl_let: rec_flag -> (pattern * expression) list -> lambda -> lambda diff --git a/bytecomp/transljoin.ml b/bytecomp/transljoin.ml index 9ec76d6f4f..f6562a0227 100644 --- a/bytecomp/transljoin.ml +++ b/bytecomp/transljoin.ml @@ -233,7 +233,7 @@ let rec is_principal id p = match p.exp_desc with | Texp_ifthenelse (_,pifso, Some pifno) -> is_principal id pifso && is_principal id pifno | Texp_ifthenelse (_,_,None) -> false -| Texp_for (_,_,_,_,_) -> false +| Texp_for (_,_,_,_,_,_) -> false | _ -> assert false (* @@ -263,11 +263,11 @@ let simple_prim = ref ((fun p -> assert false) : Primitive.description -> bool) let rec simple_pat p = match p.pat_desc with | Tpat_any | Tpat_var _ -> true -| Tpat_alias (p,_)|Tpat_lazy p -> simple_pat p +| Tpat_alias (p,_,_)|Tpat_lazy p -> simple_pat p | Tpat_tuple ps -> List.for_all simple_pat ps -| Tpat_record lps -> List.for_all (fun (_,p) -> simple_pat p) lps +| Tpat_record (lps,_) -> List.for_all (fun (_,_,_,p) -> simple_pat p) lps | Tpat_or (p1,p2,_) -> simple_pat p1 && simple_pat p2 -| Tpat_constant _|Tpat_construct (_,_)|Tpat_variant (_,_,_) +| Tpat_constant _|Tpat_construct _|Tpat_variant _ | Tpat_array _ -> false let rec simple_exp e = match e.exp_desc with @@ -285,33 +285,33 @@ let rec simple_exp e = match e.exp_desc with simple_exp e && simple_exp eifso && simple_exp_option eo | Texp_def (_,e)|Texp_loc(_,e) -> simple_exp e (* Simple simple expressions *) -| Texp_ident _ | Texp_constant _ | Texp_function (_,_) +| Texp_ident _ | Texp_constant _ | Texp_function _ | Texp_variant (_,None) -| Texp_instvar (_,_) | Texp_setinstvar (_, _, _) | Texp_spawn (_) +| Texp_instvar _ | Texp_setinstvar _ | Texp_spawn (_) -> true (* Recursion *) -| Texp_construct (_,es) | Texp_tuple (es) | Texp_array (es) +| Texp_construct (_,_,_,es,_) | Texp_tuple (es) | Texp_array (es) -> List.for_all simple_exp es -| Texp_variant (_, Some e) | Texp_field (e,_) +| Texp_variant (_, Some e) | Texp_field (e,_,_,_) -> simple_exp e -| Texp_setfield (e1,_,e2) -> simple_exp e1 && simple_exp e2 -| Texp_apply ({exp_desc=Texp_ident (_, {val_kind=Val_prim p})}, args) -> +| Texp_setfield (e1,_,_,_,e2) -> simple_exp e1 && simple_exp e2 +| Texp_apply ({exp_desc=Texp_ident (_,_,{val_kind=Val_prim p})}, args) -> List.length args < p.prim_arity || (* will be compiled as function *) (!simple_prim p && - List.for_all (fun (eo,_) -> simple_exp_option eo) args) + List.for_all (fun (_,eo,_) -> simple_exp_option eo) args) | Texp_apply (_,_) -> false -| Texp_for (_,e1,e2,_,e3) -> +| Texp_for (_,_,e1,e2,_,e3) -> simple_exp e1 && simple_exp e2 && simple_exp e3 | Texp_record (les,eo) -> - List.for_all (fun (_,e) -> simple_exp e) les && + List.for_all (fun (_,_,_,e) -> simple_exp e) les && simple_exp_option eo (* Asserts are special *) | Texp_assert e -> !Clflags.noassert || simple_exp e | Texp_assertfalse -> !Clflags.noassert (* Who knows ? *) -| Texp_letmodule (_,_,_) | Texp_override (_,_) | Texp_lazy (_) -| Texp_send (_,_) | Texp_while (_,_) | Texp_new (_,_) | Texp_try (_,_) -| Texp_object (_, _, _) | Texp_pack _ +| Texp_letmodule _ | Texp_override (_,_) | Texp_lazy (_) +| Texp_send _ | Texp_while (_,_) | Texp_new _ | Texp_try (_,_) +| Texp_object _| Texp_pack _ -> false (* Process constructs are not errors *) | Texp_reply (_, _)|Texp_par (_, _)|Texp_asyncsend (_, _) @@ -338,7 +338,7 @@ and simple_proc p = match p.exp_desc with | Texp_ifthenelse (e, pifso, None) -> simple_exp e && simple_proc pifso | Texp_def (_,p)|Texp_loc(_,p) -> simple_proc p -| Texp_for (_,e1,e2,_,_body) -> (* _body is compiled so a not to fail *) +| Texp_for (_,_,e1,e2,_,_body) -> (* _body is compiled so a not to fail *) simple_exp e1 && simple_exp e2 (* Process constructs *) | Texp_reply (e, _) -> simple_exp e @@ -346,13 +346,13 @@ and simple_proc p = match p.exp_desc with | Texp_asyncsend (e1, e2) -> simple_exp e1 && simple_exp e2 | Texp_null -> true (* Plain expressions no longer are errors *) -| Texp_spawn _|Texp_object (_, _, _)|Texp_lazy _|Texp_assert _| - Texp_letmodule (_, _, _)|Texp_override (_, _)|Texp_setinstvar (_, _, _)| - Texp_instvar (_, _)|Texp_new (_, _)|Texp_send (_, _)| - Texp_while (_, _)|Texp_array _| - Texp_setfield (_, _, _)|Texp_field (_, _)|Texp_record (_, _)| - Texp_variant (_, _)|Texp_construct (_, _)|Texp_tuple _|Texp_try (_, _)| - Texp_apply (_, _)|Texp_function (_, _)|Texp_constant _|Texp_ident (_, _)| +| Texp_spawn _|Texp_object _|Texp_lazy _|Texp_assert _| + Texp_letmodule _|Texp_override _|Texp_setinstvar _| + Texp_instvar _|Texp_new _|Texp_send _| + Texp_while _|Texp_array _| + Texp_setfield _|Texp_field _|Texp_record _| + Texp_variant _|Texp_construct _|Texp_tuple _|Texp_try _| + Texp_apply _|Texp_function _|Texp_constant _|Texp_ident _| Texp_assertfalse|Texp_pack _ -> assert false diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 632962a43f..13d720ee15 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -118,16 +118,16 @@ let undefined_location loc = let init_shape modl = let rec init_shape_mod env mty = match Mtype.scrape env mty with - Tmty_ident _ -> + Mty_ident _ -> raise Not_found - | Tmty_signature sg -> + | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) - | Tmty_functor(id, arg, res) -> + | Mty_functor(id, arg, res) -> raise Not_found (* can we do better? *) and init_shape_struct env sg = match sg with [] -> [] - | Tsig_value(id, vdesc) :: rem -> + | Sig_value(id, vdesc) :: rem -> let init_v = match Ctype.expand_head env vdesc.val_type with {desc = Tarrow(_,_,_,_)} -> @@ -136,19 +136,19 @@ let init_shape modl = Const_pointer 1 (* camlinternalMod.Lazy *) | _ -> raise Not_found in init_v :: init_shape_struct env rem - | Tsig_type(id, tdecl, _) :: rem -> + | Sig_type(id, tdecl, _) :: rem -> init_shape_struct (Env.add_type id tdecl env) rem - | Tsig_exception(id, edecl) :: rem -> + | Sig_exception(id, edecl) :: rem -> raise Not_found - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> init_shape_mod env mty :: init_shape_struct (Env.add_module id mty env) rem - | Tsig_modtype(id, minfo) :: rem -> + | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem - | Tsig_class(id, cdecl, _) :: rem -> + | Sig_class(id, cdecl, _) :: rem -> Const_pointer 2 (* camlinternalMod.Class *) :: init_shape_struct env rem - | Tsig_cltype(id, ctyp, _) :: rem -> + | Sig_class_type(id, ctyp, _) :: rem -> init_shape_struct env rem in try @@ -225,20 +225,21 @@ let compile_recmodule compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings (List.map - (fun (id, modl) -> + (fun ( id, _, _, modl) -> (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) bindings)) cont + (* Compile a module expression *) let rec transl_module cc rootpath mexp = match mexp.mod_desc with - Tmod_ident path -> + Tmod_ident (path,_) -> apply_coercion cc (transl_path path) | Tmod_structure str -> - transl_structure [] cc rootpath str - | Tmod_functor(param, mty, body) -> + transl_struct [] cc rootpath str + | Tmod_functor( param, _, mty, body) -> let bodypath = functor_path rootpath param in oo_wrap mexp.mod_env true (function @@ -258,11 +259,14 @@ let rec transl_module cc rootpath mexp = (apply_coercion cc) (Lapply(transl_module Tcoerce_none None funct, [transl_module ccarg None arg], mexp.mod_loc)) - | Tmod_constraint(arg, mty, ccarg) -> + | Tmod_constraint(arg, mty, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> apply_coercion cc (Translcore.transl_exp arg) +and transl_struct fields cc rootpath str = + transl_structure fields cc rootpath str.str_items + and transl_structure fields cc rootpath = function [] -> begin match cc with @@ -281,60 +285,62 @@ and transl_structure fields cc rootpath = function | _ -> fatal_error "Translmod.transl_structure" end - | Tstr_eval expr :: rem -> + | item :: rem -> + match item.str_desc with + | Tstr_eval expr -> Lsequence(transl_exp expr, transl_structure fields cc rootpath rem) - | Tstr_value(rec_flag, pat_expr_list) :: rem -> + | Tstr_value(rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in transl_let rec_flag pat_expr_list (transl_structure ext_fields cc rootpath rem) (*> JOCAML *) - | Tstr_def d :: rem -> + | Tstr_def d -> let ext_fields = rev_def_bound_idents d @ fields in transl_def d (transl_structure ext_fields cc rootpath rem) - | Tstr_loc d :: rem -> - let ext_fields = rev_loc_bound_idents d @ fields in - transl_loc d (transl_structure ext_fields cc rootpath rem) - | Tstr_exn_global (loc,path) :: rem -> + | Tstr_loc d -> assert false + | Tstr_exn_global (path,_) -> Lsequence - (Transljoin.transl_exn_global loc path, + (Transljoin.transl_exn_global item.str_loc path, transl_structure fields cc rootpath rem) (*< JOCAML *) - | Tstr_primitive(id, descr) :: rem -> - record_primitive descr; + | Tstr_primitive(id, _, descr) -> + record_primitive descr.val_val; transl_structure fields cc rootpath rem - | Tstr_type(decls) :: rem -> + | Tstr_type(decls) -> transl_structure fields cc rootpath rem - | Tstr_exception(id, decl) :: rem -> + | Tstr_exception( id, _, decl) -> Llet(Strict, id, transl_exception id (field_path rootpath id) decl, transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind(id, path) :: rem -> + | Tstr_exn_rebind( id, _, path, _) -> Llet(Strict, id, transl_path path, transl_structure (id :: fields) cc rootpath rem) - | Tstr_module(id, modl) :: rem -> + | Tstr_module( id, _, modl) -> Llet(Strict, id, transl_module Tcoerce_none (field_path rootpath id) modl, transl_structure (id :: fields) cc rootpath rem) - | Tstr_recmodule bindings :: rem -> - let ext_fields = List.rev_append (List.map fst bindings) fields in + | Tstr_recmodule bindings -> + let ext_fields = List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in compile_recmodule (fun id modl -> transl_module Tcoerce_none (field_path rootpath id) modl) bindings (transl_structure ext_fields cc rootpath rem) - | Tstr_modtype(id, decl) :: rem -> + | Tstr_modtype(id, _, decl) -> transl_structure fields cc rootpath rem - | Tstr_open path :: rem -> + | Tstr_open (path, _) -> transl_structure fields cc rootpath rem - | Tstr_class cl_list :: rem -> - let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in + | Tstr_class cl_list -> + let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in Lletrec(List.map - (fun (id, arity, meths, cl, vf) -> - (id, transl_class ids id arity meths cl vf)) + (fun (ci, meths, vf) -> + let id = ci.ci_id_class in + let cl = ci.ci_expr in + (id, transl_class ids id meths cl vf )) cl_list, transl_structure (List.rev ids @ fields) cc rootpath rem) - | Tstr_cltype cl_list :: rem -> + | Tstr_class_type cl_list -> transl_structure fields cc rootpath rem - | Tstr_include(modl, ids) :: rem -> + | Tstr_include(modl, ids) -> let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -357,7 +363,7 @@ let transl_implementation module_name (str, cc) = let module_id = Ident.create_persistent module_name in Lprim(Psetglobal module_id, [transl_label_init - (transl_structure [] cc (global_path module_id) str)]) + (transl_struct [] cc (global_path module_id) str)]) (* A variant of transl_structure used to compile toplevel structure definitions for the native-code compiler. Store the defined values in the fields @@ -383,44 +389,46 @@ let transl_store_structure glob map prims str = let rec transl_store subst = function [] -> transl_store_subst := subst; - lambda_unit - | Tstr_eval expr :: rem -> + lambda_unit + | item :: rem -> + match item.str_desc with + | Tstr_eval expr -> Lsequence(subst_lambda subst (transl_exp expr), transl_store subst rem) - | Tstr_value(rec_flag, pat_expr_list) :: rem -> + | Tstr_value(rec_flag, pat_expr_list) -> let ids = let_bound_idents pat_expr_list in let lam = transl_let rec_flag pat_expr_list (store_idents ids) in Lsequence(subst_lambda subst lam, transl_store (add_idents false ids subst) rem) (*> JOCAML *) - | Tstr_loc d::rem -> + | Tstr_loc d -> let ids = loc_bound_idents d in let lam = transl_loc d (store_idents ids) in Lsequence(subst_lambda subst lam, transl_store (add_idents false ids subst) rem) - | Tstr_def d::rem -> + | Tstr_def d -> let ids = def_bound_idents d in let lam = transl_def d (store_idents ids) in Lsequence(subst_lambda subst lam, transl_store (add_idents false ids subst) rem) - | Tstr_exn_global (loc, path)::rem -> - let lam = Transljoin.transl_exn_global loc path in + | Tstr_exn_global (path,_) -> + let lam = Transljoin.transl_exn_global item.str_loc path in Lsequence (subst_lambda subst lam, transl_store subst rem) (*< JOCAML *) - | Tstr_primitive(id, descr) :: rem -> - record_primitive descr; + | Tstr_primitive(id, _, descr) -> + record_primitive descr.val_val; transl_store subst rem - | Tstr_type(decls) :: rem -> + | Tstr_type(decls) -> transl_store subst rem - | Tstr_exception(id, decl) :: rem -> + | Tstr_exception( id, _, decl) -> let lam = transl_exception id (field_path (global_path glob) id) decl in Lsequence(Llet(Strict, id, lam, store_ident id), transl_store (add_ident false id subst) rem) - | Tstr_exn_rebind(id, path) :: rem -> + | Tstr_exn_rebind( id, _, path, _) -> let lam = subst_lambda subst (transl_path path) in Lsequence(Llet(Strict, id, lam, store_ident id), transl_store (add_ident false id subst) rem) - | Tstr_module(id, modl) :: rem -> + | Tstr_module( id, _, modl) -> let lam = transl_module Tcoerce_none (field_path (global_path glob) id) modl in (* Careful: the module value stored in the global may be different @@ -431,8 +439,8 @@ let transl_store_structure glob map prims str = (add_ident true adds id -> Pgetglobal... to subst). *) Llet(Strict, id, subst_lambda subst lam, Lsequence(store_ident id, transl_store(add_ident true id subst) rem)) - | Tstr_recmodule bindings :: rem -> - let ids = List.map fst bindings in + | Tstr_recmodule bindings -> + let ids = List.map fst4 bindings in compile_recmodule (fun id modl -> subst_lambda subst @@ -441,23 +449,25 @@ let transl_store_structure glob map prims str = bindings (Lsequence(store_idents ids, transl_store (add_idents true ids subst) rem)) - | Tstr_modtype(id, decl) :: rem -> + | Tstr_modtype(id, _, decl) -> transl_store subst rem - | Tstr_open path :: rem -> + | Tstr_open (path, _) -> transl_store subst rem - | Tstr_class cl_list :: rem -> - let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in + | Tstr_class cl_list -> + let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in let lam = Lletrec(List.map - (fun (id, arity, meths, cl, vf) -> - (id, transl_class ids id arity meths cl vf)) + (fun (ci, meths, vf) -> + let id = ci.ci_id_class in + let cl = ci.ci_expr in + (id, transl_class ids id meths cl vf)) cl_list, store_idents ids) in Lsequence(subst_lambda subst lam, transl_store (add_idents false ids subst) rem) - | Tstr_cltype cl_list :: rem -> + | Tstr_class_type cl_list -> transl_store subst rem - | Tstr_include(modl, ids) :: rem -> + | Tstr_include(modl, ids) -> let mid = Ident.create "include" in let rec store_idents pos = function [] -> transl_store (add_idents true ids subst) rem @@ -503,28 +513,31 @@ let transl_store_structure glob map prims str = (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) -let rec defined_idents = function +let rec defined_idents items = + match items with [] -> [] - | Tstr_eval expr :: rem -> defined_idents rem - | Tstr_value(rec_flag, pat_expr_list) :: rem -> + | item :: rem -> + match item.str_desc with + | Tstr_eval expr -> defined_idents rem + | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem (*> JOCAML *) - | Tstr_def d :: rem -> def_bound_idents d @ defined_idents rem - | Tstr_loc d :: rem -> loc_bound_idents d @ defined_idents rem - | Tstr_exn_global (_,_) :: rem -> defined_idents rem + | Tstr_def d -> def_bound_idents d @ defined_idents rem + | Tstr_loc d -> loc_bound_idents d @ defined_idents rem + | Tstr_exn_global (_,_) -> defined_idents rem (*< JOCAML *) - | Tstr_primitive(id, descr) :: rem -> defined_idents rem - | Tstr_type decls :: rem -> defined_idents rem - | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem - | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem - | Tstr_module(id, modl) :: rem -> id :: defined_idents rem - | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem - | 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 - | Tstr_cltype cl_list :: rem -> defined_idents rem - | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem + | Tstr_primitive(id, _, descr) -> defined_idents rem + | Tstr_type decls -> defined_idents rem + | Tstr_exception(id, _, decl) -> id :: defined_idents rem + | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem + | Tstr_module(id, _, modl) -> id :: defined_idents rem + | Tstr_recmodule decls -> List.map fst4 decls @ defined_idents rem + | Tstr_modtype(id, _, decl) -> defined_idents rem + | Tstr_open (path, _) -> defined_idents rem + | Tstr_class cl_list -> + List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem + | Tstr_class_type cl_list -> defined_idents rem + | Tstr_include(modl, ids) -> ids @ defined_idents rem (* Transform a coercion and the list of value identifiers defined by a toplevel structure into a table [id -> (pos, coercion)], @@ -565,13 +578,13 @@ let build_ident_map restr idlist = (* Compile an implementation using transl_store_structure (for the native-code compiler). *) -let transl_store_gen module_name (str, restr) topl = +let transl_store_gen module_name ({ str_items = str }, restr) topl = reset_labels (); primitive_declarations := []; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) in let f = function - | [ Tstr_eval expr ] when topl -> + | [ { str_desc = Tstr_eval expr } ] when topl -> assert (size = 0); subst_lambda !transl_store_subst (transl_exp expr) | str -> transl_store_structure module_id map prims str in @@ -622,7 +635,8 @@ let close_toplevel_term lam = IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l)) (free_variables lam) lam -let transl_toplevel_item = function +let transl_toplevel_item item = + match item.str_desc with Tstr_eval expr -> transl_exp expr | Tstr_value(rec_flag, pat_expr_list) -> @@ -636,46 +650,48 @@ let transl_toplevel_item = function | Tstr_loc (d) -> let idents = loc_bound_idents d in transl_loc d (make_sequence toploop_setvalue_id idents) - | Tstr_exn_global (loc,path) -> - Transljoin.transl_exn_global loc path + | Tstr_exn_global (path,_) -> + Transljoin.transl_exn_global item.str_loc path (*<JOCAML*) - | Tstr_primitive(id, descr) -> + | Tstr_primitive(id, _, descr) -> lambda_unit | Tstr_type(decls) -> lambda_unit - | Tstr_exception(id, decl) -> + | Tstr_exception(id, _, decl) -> toploop_setvalue id (transl_exception id None decl) - | Tstr_exn_rebind(id, path) -> + | Tstr_exn_rebind(id, _, path, _) -> toploop_setvalue id (transl_path path) - | Tstr_module(id, modl) -> + | Tstr_module(id, _, modl) -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) set_toplevel_unique_name id; toploop_setvalue id (transl_module Tcoerce_none (Some(Pident id)) modl) | Tstr_recmodule bindings -> - let idents = List.map fst bindings in + let idents = List.map fst4 bindings in compile_recmodule (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) bindings (make_sequence toploop_setvalue_id idents) - | Tstr_modtype(id, decl) -> + | Tstr_modtype(id, _, decl) -> lambda_unit - | Tstr_open path -> + | Tstr_open (path, _) -> lambda_unit | 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 (ci, _, _) -> ci.ci_id_class) cl_list in List.iter set_toplevel_unique_name ids; Lletrec(List.map - (fun (id, arity, meths, cl, vf) -> - (id, transl_class ids id arity meths cl vf)) + (fun (ci, meths, vf) -> + let id = ci.ci_id_class in + let cl = ci.ci_expr in + (id, transl_class ids id meths cl vf)) cl_list, make_sequence - (fun (id, _, _, _, _) -> toploop_setvalue_id id) + (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) cl_list) - | Tstr_cltype cl_list -> + | Tstr_class_type cl_list -> lambda_unit | Tstr_include(modl, ids) -> let mid = Ident.create "include" in @@ -692,7 +708,7 @@ let transl_toplevel_item_and_close itm = let transl_toplevel_definition str = reset_labels (); - make_sequence transl_toplevel_item_and_close str + make_sequence transl_toplevel_item_and_close str.str_items (* Compile the initialization code for a packed library *) diff --git a/byterun/.depend b/byterun/.depend index 869fc3212e..8a06d2df9f 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 \ @@ -28,7 +28,7 @@ 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 freelist.h \ @@ -37,8 +37,9 @@ finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h md5.h \ - io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -58,14 +59,14 @@ hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - fix_code.h memory.h major_gc.h freelist.h minor_gc.h reverse.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 @@ -141,7 +142,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 \ @@ -163,7 +164,7 @@ 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 freelist.h \ @@ -172,8 +173,9 @@ finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h md5.h \ - io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -195,14 +197,14 @@ instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - fix_code.h memory.h major_gc.h freelist.h minor_gc.h reverse.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 @@ -278,7 +280,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 \ @@ -300,7 +302,7 @@ 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 freelist.h \ @@ -309,8 +311,9 @@ finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h md5.h \ - io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -330,14 +333,14 @@ hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - fix_code.h memory.h major_gc.h freelist.h minor_gc.h reverse.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 index 59302e0548..7b178a46d2 100644 --- a/byterun/.ignore +++ b/byterun/.ignore @@ -4,7 +4,9 @@ prims.c opnames.h version.h ocamlrun +ocamlrun.exe ocamlrund +ocamlrund.exe ld.conf interp.a.lst *.[sd]obj diff --git a/byterun/Makefile b/byterun/Makefile index 316f69e5c6..e35121252b 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -32,7 +32,7 @@ ocamlrun$(EXE): libcamlrun.a prims.o prims.o libcamlrun.a $(BYTECCLIBS) ocamlrund$(EXE): libcamlrund.a prims.o - $(MKEXE) -g $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ + $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ prims.o libcamlrund.a $(BYTECCLIBS) libcamlrun.a: $(OBJS) diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 330c9a7b3c..2e92924382 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -33,7 +33,7 @@ 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 diff --git a/byterun/compact.c b/byterun/compact.c index d409492877..6c2164c318 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -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,62 @@ 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, live; + + 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) + live = heap_size - freewords + target_size = live * (1 + caml_percent_free / 100) + = live / 100 * (100 + caml_percent_free) + We add 1 to live/100 to make sure it isn't 0. + + We recompact if target_size < heap_size / 2 + */ + live = caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size); + target_size = (live / 100 + 1) * (100 + caml_percent_free); + 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_chunks; + caml_stat_heap_size += Chunk_size (chunk); + if (caml_stat_heap_size > caml_stat_top_heap_size){ + caml_stat_top_heap_size = caml_stat_heap_size; + } + do_compaction (); + Assert (caml_stat_heap_chunks == 1); + Assert (Chunk_next (caml_heap_start) == NULL); + } +} + void caml_compact_heap_maybe (void) { /* Estimated free words in the heap: @@ -408,7 +464,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/custom.c b/byterun/custom.c index b2d7b52065..5f6e7f9a0a 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -83,6 +83,7 @@ struct custom_operations * caml_final_custom_operations(final_fun fn) ops->hash = custom_hash_default; ops->serialize = custom_serialize_default; ops->deserialize = custom_deserialize_default; + ops->compare_ext = custom_compare_ext_default; l = caml_stat_alloc(sizeof(struct custom_operations_list)); l->ops = ops; l->next = custom_ops_final_table; diff --git a/byterun/dynlink.c b/byterun/dynlink.c index e921819e88..2a431e57d0 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -200,8 +200,15 @@ void caml_build_primitive_table_builtin(void) { int i; caml_ext_table_init(&caml_prim_table, 0x180); - for (i = 0; caml_builtin_cprim[i] != 0; i++) +#ifdef DEBUG + caml_ext_table_init(&caml_prim_name_table, 0x180); +#endif + for (i = 0; caml_builtin_cprim[i] != 0; i++) { caml_ext_table_add(&caml_prim_table, (void *) caml_builtin_cprim[i]); +#ifdef DEBUG + caml_ext_table_add(&caml_prim_name_table, strdup(caml_names_of_builtin_cprim[i])); +#endif +} } #endif /* NATIVE_CODE */ diff --git a/byterun/extern.c b/byterun/extern.c index 733622f13d..52e5b2e231 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -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" @@ -52,10 +53,61 @@ static struct trail_block extern_trail_first; static struct trail_block * extern_trail_block; static struct trail_entry * extern_trail_cur, * extern_trail_limit; + +/* Stack for pending values to marshal */ + +struct extern_item { value * v; mlsize_t count; }; + +#define EXTERN_STACK_INIT_SIZE 256 +#define EXTERN_STACK_MAX_SIZE (1024*1024*100) + +static struct extern_item extern_stack_init[EXTERN_STACK_INIT_SIZE]; + +static struct extern_item * extern_stack = extern_stack_init; +static struct extern_item * extern_stack_limit = extern_stack_init + + EXTERN_STACK_INIT_SIZE; + /* Forward declarations */ static void extern_out_of_memory(void); +static void extern_failwith(char *msg); +static void extern_stack_overflow(void); +static struct code_fragment * extern_find_code(char *addr); +static void extern_replay_trail(void); +static void free_extern_output(void); + +/* Free the extern stack if needed */ +static void extern_free_stack(void) +{ + if (extern_stack != extern_stack_init) { + free(extern_stack); + /* Reinitialize the globals for next time around */ + extern_stack = extern_stack_init; + extern_stack_limit = extern_stack + EXTERN_STACK_INIT_SIZE; + } +} + +static struct extern_item * extern_resize_stack(struct extern_item * sp) +{ + asize_t newsize = 2 * (extern_stack_limit - extern_stack); + asize_t sp_offset = sp - extern_stack; + struct extern_item * newstack; + if (newsize >= EXTERN_STACK_MAX_SIZE) extern_stack_overflow(); + if (extern_stack == extern_stack_init) { + newstack = malloc(sizeof(struct extern_item) * newsize); + if (newstack == NULL) extern_stack_overflow(); + memcpy(newstack, extern_stack_init, + sizeof(struct extern_item) * EXTERN_STACK_INIT_SIZE); + } else { + newstack = + realloc(extern_stack, sizeof(struct extern_item) * newsize); + if (newstack == NULL) extern_stack_overflow(); + } + extern_stack = newstack; + extern_stack_limit = newstack + newsize; + return newstack + sp_offset; +} /* Initialize the trail */ @@ -162,6 +214,7 @@ static void free_extern_output(void) free(blk); } extern_output_first = NULL; + extern_free_stack(); } static void grow_extern_output(intnat required) @@ -170,8 +223,7 @@ static void grow_extern_output(intnat required) intnat extra; if (extern_userprovided_output != NULL) { - extern_replay_trail(); - caml_failwith("Marshal.to_buffer: buffer overflow"); + extern_failwith("Marshal.to_buffer: buffer overflow"); } extern_output_block->end = extern_ptr; if (required <= SIZE_EXTERN_OUTPUT_BLOCK / 2) @@ -217,6 +269,21 @@ extern void extern_invalid_argument(char *msg) caml_invalid_argument(msg); } +static void extern_failwith(char *msg) +{ + extern_replay_trail(); + free_extern_output(); + caml_failwith(msg); +} + +static void extern_stack_overflow(void) +{ + caml_gc_message (0x04, "Stack overflow in marshaling value\n", 0); + extern_replay_trail(); + free_extern_output(); + caml_raise_out_of_memory(); +} + /* Write characters, integers, and blocks in the output buffer */ #define Write(c) \ @@ -292,7 +359,8 @@ static void writecode64(int code, intnat val) #ifdef DEBUG #include <stdio.h> #endif -static int32 saved_code[MAX_SAVED] ; +typedef char *saved_code_t ; +static saved_code_t saved_code[MAX_SAVED] ; static int ncodes_saved = 0 ; CAMLprim value caml_register_saved_code(value v) @@ -300,30 +368,30 @@ CAMLprim value caml_register_saved_code(value v) if (ncodes_saved >= MAX_SAVED) { caml_failwith("caml_register_saved_code called too many times\n") ; } - saved_code[ncodes_saved] = ((char *)Code_val(v)) - caml_code_area_start ; + char *c = (char *)Code_val(v) ; + saved_code[ncodes_saved] = c; #ifdef DEBUG - fprintf(stderr, "CODE%i is %i\n", ncodes_saved, saved_code[ncodes_saved]) ; + fprintf(stderr, "CODE%i is %p\n", ncodes_saved, saved_code[ncodes_saved]) ; #endif ncodes_saved++ ; return Val_unit ; } -/* Return offest in saved code tables or -1 when not present +/* Return offset in saved code tables or -1 when not present Important: assumes code is not moving */ -static int caml_find_saved_code(code_t c) +static int caml_find_saved_code(char *c) { int i ; - int32 ofs = ((char *)c) - caml_code_area_start ; for (i = 0 ; i < ncodes_saved ; i++) { - if (saved_code[i] == ofs) return i ; + if (saved_code[i] == c) return i ; } return -1 ; } -CAMLexport code_t caml_get_saved_code(int idx) +CAMLexport char *caml_get_saved_code(int idx) { if (idx < ncodes_saved) { - return (code_t)(caml_code_area_start + saved_code[idx]) ; + return saved_code[idx] ; } else { return NULL ; } @@ -380,7 +448,11 @@ CAMLexport value caml_get_saved_value(int idx) static void extern_rec(value v) { - tailcall: + struct code_fragment * cf; + struct extern_item * sp; + sp = extern_stack; + + while(1) { if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { @@ -395,7 +467,7 @@ static void extern_rec(value v) #endif } else writecode32(CODE_INT32, n); - return; + goto next_item; } if (Is_in_value_area(v)) { header_t hd = Hd_val(v); @@ -411,7 +483,7 @@ static void extern_rec(value v) /* Do not short-circuit the pointer. */ }else{ v = f; - goto tailcall; + continue; } } /* Atoms are treated specially for two reasons: they are not allocated @@ -422,7 +494,7 @@ static void extern_rec(value v) } else { writecode32(CODE_BLOCK32, hd); } - return; + goto next_item; } /* Check if already seen */ if (Color_hd(hd) == Caml_blue) { @@ -434,7 +506,7 @@ static void extern_rec(value v) } else { writecode32(CODE_SHARED32, d); } - return; + goto next_item; } /* Output the contents of the object */ @@ -521,7 +593,6 @@ static void extern_rec(value v) /* <JOCAML */ { value field0; - mlsize_t i; if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR @@ -535,34 +606,45 @@ static void extern_rec(value v) size_64 += 1 + sz; field0 = Field(v, 0); extern_record_location(v); - if (sz == 1) { - v = field0; - } else { - extern_rec(field0); - for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i)); - v = Field(v, i); + /* Remember that we still have to serialize fields 1 ... sz - 1 */ + if (sz > 1) { + sp++; + if (sp >= extern_stack_limit) sp = extern_resize_stack(sp); + sp->v = &Field(v,1); + sp->count = sz-1; } - goto tailcall; + /* Continue serialization with the first field */ + v = field0; + continue; } } } - else if ((char *) v >= caml_code_area_start && - (char *) v < caml_code_area_end) { + else if ((cf = extern_find_code((char *) v)) != NULL) { /* >JOCAML */ int ofs = caml_find_saved_code((code_t)v) ; if (ofs >= 0) { Write(CODE_SAVEDCODE) ; Write(ofs) ; - return ; } /* <JOCAML */ - if (!extern_closures) + else 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)"); } + next_item: + /* Pop one more item to marshal, if any */ + if (sp == extern_stack) { + /* We are done. Cleanup the stack and leave the function */ + extern_free_stack(); + return; + } + v = *((sp->v)++); + if (--(sp->count) == 0) sp--; + } + /* Never reached as function leaves with return */ } enum { NO_SHARING = 1, CLOSURES = 2 }; @@ -840,3 +922,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/fix_code.c b/byterun/fix_code.c index 7a8f1ffa55..e47b8ac004 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -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" @@ -37,18 +38,28 @@ unsigned char caml_code_md5[16]; /* Read the main bytecode block from a file */ +void caml_init_code_fragments() { + struct code_fragment * cf; + /* 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); +} + void caml_load_code(int fd, asize_t len) { int i; - struct MD5Context ctx; 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); + caml_init_code_fragments(); + /* 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 fb47b6c4dd..05f9ae060b 100644 --- a/byterun/fix_code.h +++ b/byterun/fix_code.h @@ -26,8 +26,8 @@ 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_init_code_fragments(); void caml_load_code (int fd, asize_t len); void caml_fixup_endianness (code_t code, asize_t len); void caml_set_instruction (code_t pos, opcode_t instr); diff --git a/byterun/freelist.c b/byterun/freelist.c index f3bb4a8ee0..6b50d3f9e6 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -532,14 +532,14 @@ void caml_set_allocation_policy (uintnat p) switch (p){ case Policy_next_fit: fl_prev = Fl_head; + policy = p; break; case Policy_first_fit: flp_size = 0; beyond = NULL; + policy = p; break; default: - Assert (0); break; } - policy = p; } diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index b5c4366798..2ae3165d9f 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -356,21 +356,12 @@ static intnat norm_minsize (intnat s) return s; } -static intnat norm_policy (intnat p) -{ - if (p >= 0 && p <= 1){ - return p; - }else{ - return 1; - } -} - CAMLprim value caml_gc_set(value v) { uintnat newpf, newpm; asize_t newheapincr; asize_t newminsize; - uintnat newpolicy; + uintnat oldpolicy; caml_verb_gc = Long_val (Field (v, 3)); @@ -396,10 +387,11 @@ CAMLprim value caml_gc_set(value v) caml_gc_message (0x20, "New heap increment size: %luk bytes\n", caml_major_heap_increment/1024); } - newpolicy = norm_policy (Long_val (Field (v, 6))); - if (newpolicy != caml_allocation_policy){ - caml_gc_message (0x20, "New allocation policy: %d\n", newpolicy); - caml_set_allocation_policy (newpolicy); + oldpolicy = caml_allocation_policy; + caml_set_allocation_policy (Long_val (Field (v, 6))); + if (oldpolicy != caml_allocation_policy){ + caml_gc_message (0x20, "New allocation policy: %d\n", + caml_allocation_policy); } /* Minor heap size comes last because it will trigger a minor collection diff --git a/byterun/intern.c b/byterun/intern.c index 6411be74da..bea32b4027 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -18,6 +18,7 @@ /* The interface of this file is "intext.h" */ #include <string.h> +#include <stdio.h> #include "alloc.h" #include "callback.h" #include "custom.h" @@ -25,6 +26,7 @@ #include "gc.h" #include "intext.h" #include "io.h" +#include "md5.h" #include "memory.h" #include "mlvalues.h" #include "misc.h" @@ -68,6 +70,12 @@ 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; + +static void intern_free_stack(void); + #define Sign_extend_shift ((sizeof(intnat) - 1) * 8) #define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift) @@ -114,27 +122,201 @@ static void intern_cleanup(void) /* restore original header for heap block, otherwise GC is confused */ Hd_val(intern_block) = intern_header; } + /* free the recursion stack */ + intern_free_stack(); +} + +static void readfloat(double * dest, unsigned int code) +{ + if (sizeof(double) != 8) { + intern_cleanup(); + caml_invalid_argument("input_value: non-standard floats"); + } + readblock((char *) dest, 8); + /* Fix up endianness, if needed */ +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 + /* Host is big-endian; fix up if data read is little-endian */ + if (code != CODE_DOUBLE_BIG) Reverse_64(dest, dest); +#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 + /* Host is little-endian; fix up if data read is big-endian */ + if (code != CODE_DOUBLE_LITTLE) Reverse_64(dest, dest); +#else + /* Host is neither big nor little; permute as appropriate */ + if (code == CODE_DOUBLE_LITTLE) + Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x01234567) + else + Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x76543210); +#endif +} + +static void readfloats(double * dest, mlsize_t len, unsigned int code) +{ + mlsize_t i; + if (sizeof(double) != 8) { + intern_cleanup(); + caml_invalid_argument("input_value: non-standard floats"); + } + readblock((char *) dest, len * 8); + /* Fix up endianness, if needed */ +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 + /* Host is big-endian; fix up if data read is little-endian */ + if (code != CODE_DOUBLE_ARRAY8_BIG && + code != CODE_DOUBLE_ARRAY32_BIG) { + for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i); + } +#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 + /* Host is little-endian; fix up if data read is big-endian */ + if (code != CODE_DOUBLE_ARRAY8_LITTLE && + code != CODE_DOUBLE_ARRAY32_LITTLE) { + for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i); + } +#else + /* Host is neither big nor little; permute as appropriate */ + if (code == CODE_DOUBLE_ARRAY8_LITTLE || + code == CODE_DOUBLE_ARRAY32_LITTLE) { + for (i = 0; i < len; i++) + Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x01234567); + } else { + for (i = 0; i < len; i++) + Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x76543210); + } +#endif } -void caml_intern_cleanup(void) { - intern_cleanup() ; +/* Item on the stack with defined operation */ +struct intern_item { + value * dest; + intnat arg; + enum { + OReadItems, /* read arg items and store them in dest[0], dest[1], ... */ + OFreshOID, /* generate a fresh OID and store it in *dest */ + OShift /* offset *dest by arg */ + } op; +}; + +/* FIXME: This is duplicated in two other places, with the only difference of + the type of elements stored in the stack. Possible solution in C would + be to instantiate stack these function via. C preprocessor macro. + */ + +#define INTERN_STACK_INIT_SIZE 256 +#define INTERN_STACK_MAX_SIZE (1024*1024*100) + +static struct intern_item intern_stack_init[INTERN_STACK_INIT_SIZE]; + +static struct intern_item * intern_stack = intern_stack_init; +static struct intern_item * intern_stack_limit = intern_stack_init + + INTERN_STACK_INIT_SIZE; + +/* Free the recursion stack if needed */ +static void intern_free_stack(void) +{ + if (intern_stack != intern_stack_init) { + free(intern_stack); + /* Reinitialize the globals for next time around */ + intern_stack = intern_stack_init; + intern_stack_limit = intern_stack + INTERN_STACK_INIT_SIZE; + } } +/* Same, then raise Out_of_memory */ +static void intern_stack_overflow(void) +{ + caml_gc_message (0x04, "Stack overflow in un-marshaling value\n", 0); + intern_free_stack(); + caml_raise_out_of_memory(); +} + +static struct intern_item * intern_resize_stack(struct intern_item * sp) +{ + asize_t newsize = 2 * (intern_stack_limit - intern_stack); + asize_t sp_offset = sp - intern_stack; + struct intern_item * newstack; + + if (newsize >= INTERN_STACK_MAX_SIZE) intern_stack_overflow(); + if (intern_stack == intern_stack_init) { + newstack = malloc(sizeof(struct intern_item) * newsize); + if (newstack == NULL) intern_stack_overflow(); + memcpy(newstack, intern_stack_init, + sizeof(struct intern_item) * INTERN_STACK_INIT_SIZE); + } else { + newstack = + realloc(intern_stack, sizeof(struct intern_item) * newsize); + if (newstack == NULL) intern_stack_overflow(); + } + intern_stack = newstack; + intern_stack_limit = newstack + newsize; + return newstack + sp_offset; +} + +/* Convenience macros for requesting operation on the stack */ +#define PushItem() \ + do { \ + sp++; \ + if (sp >= intern_stack_limit) sp = intern_resize_stack(sp); \ + } while(0) + +#define ReadItems(_dest,_n) \ + do { \ + if (_n > 0) { \ + PushItem(); \ + sp->op = OReadItems; \ + sp->dest = _dest; \ + sp->arg = _n; \ + } \ + } while(0) + + static void intern_rec(value *dest) { unsigned int code; tag_t tag; mlsize_t size, len, ofs_ind; - value v, clos; + value v; asize_t ofs; header_t header; - char cksum[16]; + unsigned char digest[16]; struct custom_operations * ops; - value * function_placeholder; - int get_function_placeholder; - - get_function_placeholder = 1; - tailcall: + char * codeptr; + struct intern_item * sp; + + sp = intern_stack; + + /* Initially let's try to read the first object from the stream */ + ReadItems(dest, 1); + + /* The un-marshaler loop, the recursion is unrolled */ + while(sp != intern_stack) { + + /* Interpret next item on the stack */ + dest = sp->dest; + switch (sp->op) { + case OFreshOID: + /* Refresh the object ID */ + if (camlinternaloo_last_id == NULL) { + camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); + if (camlinternaloo_last_id == NULL) + camlinternaloo_last_id = (value*) (-1); + } + if (camlinternaloo_last_id != (value*) (-1)) { + value id = Field(*camlinternaloo_last_id,0); + Field(dest, 0) = id; + Field(*camlinternaloo_last_id,0) = id + 2; + } + /* Pop item and iterate */ + sp--; + break; + case OShift: + /* Shift value by an offset */ + *dest += sp->arg; + /* Pop item and iterate */ + sp--; + break; + case OReadItems: + /* Pop item */ + sp->dest++; + if (--(sp->arg) == 0) sp--; + /* Read a value and set v to this value */ code = read8u(); if (code >= PREFIX_SMALL_INT) { if (code >= PREFIX_SMALL_BLOCK) { @@ -146,30 +328,24 @@ static void intern_rec(value *dest) v = Atom(tag); } else { 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, 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; + if (tag == Object_tag) { + Assert(size >= 2); + /* Request to read rest of the elements of the block */ + ReadItems(&Field(v, 2), size - 2); + /* Request freshing OID */ + PushItem(); + sp->op = OFreshOID; + sp->dest = &Field(v, 1); + sp->arg = 1; + /* Finally read first two block elements: method table and old OID */ + ReadItems(&Field(v, 0), 2); + } else + /* If it's not an object then read the contents of the block */ + ReadItems(&Field(v, 0), size); } } else { /* Small integer */ @@ -248,68 +424,22 @@ static void intern_rec(value *dest) goto read_string; case CODE_DOUBLE_LITTLE: case CODE_DOUBLE_BIG: - if (sizeof(double) != 8) { - intern_cleanup(); - caml_invalid_argument("input_value: non-standard floats"); - } v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); intern_dest += 1 + Double_wosize; - readblock((char *) v, 8); -#if ARCH_FLOAT_ENDIANNESS == 0x76543210 - if (code != CODE_DOUBLE_BIG) Reverse_64(v, v); -#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 - if (code != CODE_DOUBLE_LITTLE) Reverse_64(v, v); -#else - if (code == CODE_DOUBLE_LITTLE) - Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x01234567) - else - Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x76543210); -#endif + readfloat((double *) v, code); break; case CODE_DOUBLE_ARRAY8_LITTLE: case CODE_DOUBLE_ARRAY8_BIG: len = read8u(); read_double_array: - if (sizeof(double) != 8) { - intern_cleanup(); - caml_invalid_argument("input_value: non-standard floats"); - } size = len * Double_wosize; v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(size, Double_array_tag, intern_color); intern_dest += 1 + size; - readblock((char *) v, len * 8); -#if ARCH_FLOAT_ENDIANNESS == 0x76543210 - if (code != CODE_DOUBLE_ARRAY8_BIG && - code != CODE_DOUBLE_ARRAY32_BIG) { - mlsize_t i; - for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), - (value)((double *)v + i)); - } -#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 - if (code != CODE_DOUBLE_ARRAY8_LITTLE && - code != CODE_DOUBLE_ARRAY32_LITTLE) { - mlsize_t i; - for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), - (value)((double *)v + i)); - } -#else - if (code == CODE_DOUBLE_ARRAY8_LITTLE || - code == CODE_DOUBLE_ARRAY32_LITTLE) { - mlsize_t i; - for (i = 0; i < len; i++) - Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS, - (value)((double *)v + i), 0x01234567); - } else { - mlsize_t i; - for (i = 0; i < len; i++) - Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS, - (value)((double *)v + i), 0x76543210); - } -#endif + readfloats((double *) v, len, code); break; case CODE_DOUBLE_ARRAY32_LITTLE: case CODE_DOUBLE_ARRAY32_BIG: @@ -317,21 +447,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) { - if (get_function_placeholder) { - function_placeholder = - caml_named_value ("Debugger.function_placeholder"); - get_function_placeholder = 0; - } + 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; - break; + } else { + intern_cleanup(); + intern_bad_code_pointer(digest); } - intern_cleanup(); - caml_failwith("input_value: code mismatch"); } - v = (value) (caml_code_area_start + ofs); break; /*>JOCAML*/ case CODE_SAVEDCODE: @@ -356,9 +485,13 @@ static void intern_rec(value *dest) /*<JOCAML*/ case CODE_INFIXPOINTER: ofs = read32u(); - intern_rec(&clos); - v = clos + ofs; - break; + /* Read a value to *dest, then offset *dest by ofs */ + PushItem(); + sp->dest = dest; + sp->op = OShift; + sp->arg = ofs; + ReadItems(dest, 1); + continue; /* with next iteration of main loop, skipping *dest = v */ case CODE_CUSTOM: /*>JOCAML*/ custom_tag = Custom_tag ; @@ -386,8 +519,16 @@ static void intern_rec(value *dest) caml_failwith("input_value: ill-formed message"); } } - } + } + /* end of case OReadItems */ *dest = v; + break; + default: + Assert(0); + } + } + /* We are done. Cleanup the stack and leave the function */ + intern_free_stack(); } static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) @@ -619,40 +760,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/intext.h b/byterun/intext.h index 57c1def801..8cdce36789 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -161,25 +161,25 @@ CAMLextern void caml_deserialize_error(char * msg); /* <private> */ /* 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; /* </private> */ /* >JOCAML */ CAMLextern void extern_invalid_argument(char *msg) ; -CAMLextern code_t caml_get_saved_code(int idx) ; +CAMLextern char *caml_get_saved_code(int idx) ; CAMLextern value caml_get_saved_value(int idx) ; -/*<JOCAML*/ /* <JOCAML */ + #ifdef __cplusplus } #endif diff --git a/byterun/io.c b/byterun/io.c index 600887a889..ae9e397065 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -279,6 +279,11 @@ CAMLexport int caml_do_read(int fd, char *p, unsigned int n) do { caml_enter_blocking_section(); retcode = read(fd, p, n); +#if defined(_WIN32) + if (retcode == -1 && errno == ENOMEM && n > 16384){ + retcode = read(fd, p, 16384); + } +#endif caml_leave_blocking_section(); } while (retcode == -1 && errno == EINTR); if (retcode == -1) caml_sys_io_error(NO_ARG); diff --git a/byterun/io.h b/byterun/io.h index 53d9bb9bf4..89a85380c7 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -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/major_gc.c b/byterun/major_gc.c index aeb192fdea..1d290a5730 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -233,7 +233,11 @@ static void mark_slice (intnat work) weak_prev = &Field (cur, 0); work -= Whsize_hd (hd); }else{ - /* Subphase_weak1 is done. Start removing dead weak arrays. */ + /* Subphase_weak1 is done. + Handle finalised values and start removing dead weak arrays. */ + gray_vals_cur = gray_vals_ptr; + caml_final_update (); + gray_vals_ptr = gray_vals_cur; caml_gc_subphase = Subphase_weak2; weak_prev = &caml_weak_list_head; } @@ -254,10 +258,7 @@ static void mark_slice (intnat work) } work -= 1; }else{ - /* Subphase_weak2 is done. Handle finalised values. */ - gray_vals_cur = gray_vals_ptr; - caml_final_update (); - gray_vals_ptr = gray_vals_cur; + /* Subphase_weak2 is done. Go to Subphase_final. */ caml_gc_subphase = Subphase_final; } } diff --git a/byterun/md5.c b/byterun/md5.c index 41a86ed726..a212512732 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -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 7a3799eb3c..0c4239e550 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -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 b0801f130b..b99825d185 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -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) { diff --git a/byterun/meta.c b/byterun/meta.c index 73287f79d6..a547b991b5 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -15,6 +15,7 @@ /* Primitives for the toplevel */ +#include <string.h> #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/startup.c b/byterun/startup.c index feb5029ae9..8298fe83ff 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -443,6 +443,10 @@ CAMLexport void caml_startup_code( { value res; char* cds_file; + char * exe_name; +#ifdef __linux__ + static char proc_self_exe[256]; +#endif caml_init_ieee_floats(); caml_init_custom_operations(); @@ -455,6 +459,11 @@ CAMLexport void caml_startup_code( strcpy(caml_cds_file, cds_file); } parse_camlrunparam(); + exe_name = argv[0]; +#ifdef __linux__ + if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) + exe_name = proc_self_exe; +#endif caml_external_raise = NULL; /* Initialize the abstract machine */ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, @@ -468,6 +477,7 @@ CAMLexport void caml_startup_code( /* Load the code */ caml_start_code = code; caml_code_size = code_size; + caml_init_code_fragments(); if (caml_debugger_in_use) { int len, i; len = code_size / sizeof(opcode_t); @@ -489,7 +499,7 @@ CAMLexport void caml_startup_code( caml_section_table_size = section_table_size; /* Initialize system libraries */ caml_init_exceptions(); - caml_sys_init("", argv); + caml_sys_init(exe_name, argv); /* Execute the program */ caml_debugger(PROGRAM_START); res = caml_interprete(caml_start_code, caml_code_size); diff --git a/byterun/sys.c b/byterun/sys.c index dcc2907562..ce364d8c1a 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -291,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) diff --git a/compilerlibs/.gitignore b/compilerlibs/.gitignore new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/compilerlibs/.gitignore diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 41a31fbabd..5176f34a0c 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -19,6 +19,9 @@ PREFIX=C:/jocamlmgw +### Remove this to disable compiling camlp4 +CAMLP4=camlp4 + ### Where to install the binaries BINDIR=$(PREFIX)/bin @@ -69,7 +72,6 @@ ASM=$(TOOLPREF)as ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof -RUNTIMED=noruntimed DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= @@ -78,6 +80,7 @@ EXTRALIBS= NATDYNLINK=true CMXS=cmxs RUNTIMED=noruntimed +ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler @@ -101,7 +104,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) diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index d4a0564114..0823be5fe9 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -19,6 +19,9 @@ PREFIX=C:/ocamlmgw64 +### Remove this to disable compiling camlp4 +CAMLP4=camlp4 + ### Where to install the binaries BINDIR=$(PREFIX)/bin @@ -69,7 +72,6 @@ ASM=$(TOOLPREF)as ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof -RUNTIMED=noruntimed DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= @@ -78,6 +80,7 @@ EXTRALIBS= NATDYNLINK=true CMXS=cmxs RUNTIMED=noruntimed +ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler @@ -101,7 +104,7 @@ NATIVECCLIBS=-lws2_32 CPP=$(BYTECC) -E ### Flexlink -FLEXLINK=flexlink -chain mingw64 +FLEXLINK=flexlink -chain mingw64 -stack 33554432 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 188c7f8ccb..be61fa95ee 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -72,6 +72,7 @@ EXTRALIBS= CMXS=cmxs NATDYNLINK=true RUNTIMED=noruntimed +ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler @@ -95,11 +96,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 diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 2b3edcd56e..82e0aadedd 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -72,6 +72,7 @@ SYSTHREAD_SUPPORT=true CMXS=cmxs NATDYNLINK=true RUNTIMED=noruntimed +ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler @@ -100,11 +101,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 @@ -146,6 +147,13 @@ NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=link /lib /nologo /machine:AMD64 /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 diff --git a/config/auto-aux/cfi.S b/config/auto-aux/cfi.S index e055423a92..acd052df0b 100644 --- a/config/auto-aux/cfi.S +++ b/config/auto-aux/cfi.S @@ -1,3 +1,6 @@ -.cfi_startproc -.cfi_adjust_cfa_offset 8 -.cfi_endproc +camlPervasives__loop_1128: + .file 1 "pervasives.ml" + .loc 1 193 + .cfi_startproc + .cfi_adjust_cfa_offset 8 + .cfi_endproc diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble index feffbed264..7cd5582c8c 100644 --- a/config/auto-aux/tryassemble +++ b/config/auto-aux/tryassemble @@ -5,3 +5,13 @@ $aspp -o tst $* || exit 100 else $aspp -o tst $* 2> /dev/null || exit 100 fi + +# test as also (if differs) +if test "$aspp" != "$as"; then +if test "$verbose" = yes; then +echo "tryassemble: $as -o tst $*" >&2 +$as -o tst $* || exit 100 +else +$as -o tst $* 2> /dev/null || exit 100 +fi +fi @@ -303,6 +303,7 @@ esac bytecc="$cc" mkexe="\$(BYTECC)" +mkexedebugflag="-g" bytecccompopts="" bytecclinkopts="" dllccompopts="" @@ -320,7 +321,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) @@ -367,7 +368,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" @@ -375,6 +376,7 @@ case "$bytecc,$host" in else iflexdir="-I\"$flexdir\"" mkexe="$flexlink -exe" + mkexedebugflag="-link -g" fi fi exe=".exe" @@ -674,6 +676,7 @@ if test $withsharedlibs = "yes"; then case "$host" in *-*-cygwin*) natdynlink=true;; i[3456]86-*-linux*) natdynlink=true;; + i[3456]86-*-gnu*) natdynlink=true;; x86_64-*-linux*) natdynlink=true;; i[3456]86-*-darwin[89].*) natdynlink=true;; i[3456]86-*-darwin*) @@ -681,8 +684,8 @@ if test $withsharedlibs = "yes"; then natdynlink=true fi;; x86_64-*-darwin*) natdynlink=true;; - powerpc64-*-linux*) natdynlink=true;; - sparc-*-linux*) natdynlink=true;; + powerpc*-*-linux*) natdynlink=true;; + sparc*-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; x86_64-*-kfreebsd*) natdynlink=true;; i[345]86-*-freebsd*) natdynlink=true;; @@ -1166,6 +1169,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 @@ -1603,11 +1611,14 @@ fi asm_cfi_supported=false -export aspp +export as aspp if sh ./tryassemble cfi.S; then echo "#define ASM_CFI_SUPPORTED" >> m.h asm_cfi_supported=true + echo "Assembler supports CFI" +else + echo "Assembler does not support CFI" fi # Final twiddling of compiler options to work around known bugs @@ -1677,6 +1688,7 @@ echo "TOOLCHAIN=cc" >> Makefile echo "NATDYNLINK=$natdynlink" >> Makefile echo "CMXS=$cmxs" >> Makefile echo "MKEXE=$mkexe" >> Makefile +echo "MKEXEDEBUGFLAG=$mkexedebugflag" >> Makefile echo "MKDLL=$mksharedlib" >> Makefile echo "MKMAINDLL=$mkmaindll" >> Makefile echo "RUNTIMED=${debugruntime}" >>Makefile @@ -1773,8 +1785,8 @@ 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 $x11_includes" -echo " options for linking ...... $tk_libs $x11_link" +echo " options for compiling .... $tk_defs $tk_x11_include" +echo " options for linking ...... $tk_libs $tk_x11_libs" else echo "The \"labltk\" library: not supported" fi diff --git a/driver/compile.ml b/driver/compile.ml index 35a5cc8543..531e214f6f 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -79,17 +79,21 @@ let interface ppf sourcefile outputprefix = check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in + let initial_env = initial_env () in try let ast = Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; - let sg = Typemod.transl_signature (initial_env()) ast in + let tsg = Typemod.transl_signature initial_env ast in if !Clflags.print_types then fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature sg); + (Typemod.simplify_signature tsg.sig_type); Warnings.check_fatal (); - if not !Clflags.print_types then - Env.save_signature sg modulename (outputprefix ^ ".cmi"); + if not !Clflags.print_types then begin + let sg = Env.save_signature tsg.sig_type modulename (outputprefix ^ ".cmi") in + Typemod.save_signature modulename tsg outputprefix sourcefile + initial_env sg ; + end; Pparse.remove_preprocessed inputfile with e -> Pparse.remove_preprocessed_if_ast inputfile; @@ -116,9 +120,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 (Some (outputprefix ^ ".annot")); with x -> Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (Some (outputprefix ^ ".annot")); raise x end else begin let objfile = outputprefix ^ ".cmo" in @@ -137,12 +145,12 @@ let implementation ppf sourcefile outputprefix = Warnings.check_fatal (); close_out oc; Pparse.remove_preprocessed inputfile; - Stypes.dump (outputprefix ^ ".annot"); + Stypes.dump (Some (outputprefix ^ ".annot")); with x -> close_out oc; remove_file objfile; Pparse.remove_preprocessed_if_ast inputfile; - Stypes.dump (outputprefix ^ ".annot"); + Stypes.dump (Some (outputprefix ^ ".annot")); raise x end diff --git a/driver/errors.ml b/driver/errors.ml index 9400e9ebc5..47ae99542f 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -34,6 +34,9 @@ let report_error ppf exn = | Env.Error err -> Location.print_error_cur_file ppf; Env.report_error ppf err + | Cmi_format.Error err -> + Location.print_error_cur_file ppf; + Cmi_format.report_error ppf err | Ctype.Tags(l, l') -> Location.print_error_cur_file ppf; fprintf ppf diff --git a/driver/main.ml b/driver/main.ml index a78298ee98..1e41d19f5a 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -99,6 +99,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _a = set make_archive let _absname = set Location.absname let _annot = set annotations + let _binannot = set binary_annotations let _c = set compile_only let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs diff --git a/driver/main_args.ml b/driver/main_args.ml index ff9aa9e223..6bbee563c9 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -24,6 +24,10 @@ let mk_annot f = "-annot", Arg.Unit f, " Save information in <filename>.annot" ;; +let mk_binannot f = + "-bin-annot", Arg.Unit f, " Save typedtree in <filename>.cmt" +;; + let mk_c f = "-c", Arg.Unit f, " Compile only (do not link)" ;; @@ -401,6 +405,7 @@ module type Bytecomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit + val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -489,6 +494,7 @@ module type Optcomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit + val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -612,6 +618,7 @@ struct mk_a F._a; mk_absname F._absname; mk_annot F._annot; + mk_binannot F._binannot; mk_c F._c; mk_cc F._cc; mk_cclib F._cclib; @@ -711,6 +718,7 @@ struct mk_a F._a; mk_absname F._absname; mk_annot F._annot; + mk_binannot F._binannot; mk_c F._c; mk_cc F._cc; mk_cclib F._cclib; diff --git a/driver/main_args.mli b/driver/main_args.mli index 112bbc2f9a..13a384b128 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -17,6 +17,7 @@ module type Bytecomp_options = val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit + val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -106,6 +107,7 @@ module type Optcomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit + val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index ddcbd260a4..b727f25409 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -78,22 +78,25 @@ let interface ppf sourcefile outputprefix = check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in + let initial_env = initial_env() in try let ast = Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; - let sg = Typemod.transl_signature (initial_env()) ast in + let tsg = Typemod.transl_signature initial_env ast in if !Clflags.print_types then fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature sg); + (Typemod.simplify_signature tsg.sig_type); Warnings.check_fatal (); - if not !Clflags.print_types then - Env.save_signature sg modulename (outputprefix ^ ".cmi"); + if not !Clflags.print_types then begin + let sg = Env.save_signature tsg.sig_type modulename (outputprefix ^ ".cmi") in + Typemod.save_signature modulename tsg outputprefix sourcefile initial_env sg ; + end; Pparse.remove_preprocessed inputfile; - Stypes.dump (outputprefix ^ ".annot"); + Stypes.dump (Some (outputprefix ^ ".annot")) with e -> Pparse.remove_preprocessed_if_ast inputfile; - Stypes.dump (outputprefix ^ ".annot"); + Stypes.dump (Some (outputprefix ^ ".annot")); raise e (* Compile a .ml file *) @@ -135,12 +138,12 @@ let implementation ppf sourcefile outputprefix = end; Warnings.check_fatal (); Pparse.remove_preprocessed inputfile; - Stypes.dump (outputprefix ^ ".annot"); + Stypes.dump (Some (outputprefix ^ ".annot")); with x -> remove_file objfile; remove_file cmxfile; Pparse.remove_preprocessed_if_ast inputfile; - Stypes.dump (outputprefix ^ ".annot"); + Stypes.dump (Some (outputprefix ^ ".annot")); raise x let c_file name = diff --git a/driver/opterrors.ml b/driver/opterrors.ml index f931990a4c..a30c2de267 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -33,6 +33,9 @@ let report_error ppf exn = | Env.Error err -> Location.print_error_cur_file ppf; Env.report_error ppf err + | Cmi_format.Error err -> + Location.print_error_cur_file ppf; + Cmi_format.report_error ppf err | Ctype.Tags(l, l') -> Location.print_error_cur_file ppf; fprintf ppf diff --git a/driver/optmain.ml b/driver/optmain.ml index b84cac8ec4..8c80d47bea 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -110,6 +110,7 @@ module Options = Main_args.Make_optcomp_options (struct let _a = set make_archive let _absname = set Location.absname let _annot = set annotations + let _binannot = set binary_annotations let _c = set compile_only let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs diff --git a/driver/pparse.ml b/driver/pparse.ml index dae174cea2..1d205036c6 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -22,7 +22,7 @@ let preprocess sourcefile = match !Clflags.preprocessor with None -> sourcefile | Some pp -> - let tmpfile = Filename.temp_file "camlpp" "" in + let tmpfile = Filename.temp_file "ocamlpp" "" in let comm = Printf.sprintf "%s %s > %s" pp (Filename.quote sourcefile) tmpfile in diff --git a/emacs/caml-types.el b/emacs/caml-types.el index e42a0fc46d..d63eaf16a1 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -594,7 +594,7 @@ The function uses two overlays. . One overlay delimits the largest region whose all subnodes are well-typed. . Another overlay delimits the current node under the mouse (whose type - annotation is beeing displayed). + annotation is being displayed). " (interactive "e") (set-buffer (window-buffer (caml-event-window event))) @@ -686,30 +686,30 @@ The function uses two overlays. target-pos (vector target-file target-line target-bol cnum)) (save-excursion - (setq node (caml-types-find-location "type" - target-pos () target-tree)) + (setq node (caml-types-find-location target-pos "type" () + target-tree)) (set-buffer caml-types-buffer) (erase-buffer) (cond - (node - (setq Left - (caml-types-get-pos target-buf (elt node 0)) - Right - (caml-types-get-pos target-buf (elt node 1))) - (move-overlay - caml-types-expr-ovl Left Right target-buf) - (setq limits - (caml-types-find-interval target-buf - target-pos node) - type (elt node 2)) - ) - (t + ((null node) (delete-overlay caml-types-expr-ovl) (setq type "*no type information*") (setq limits (caml-types-find-interval - target-buf target-pos target-tree)) + target-buf target-pos target-tree))) + (t + (let ((left + (caml-types-get-pos target-buf (elt node 0))) + (right + (caml-types-get-pos target-buf (elt node 1)))) + (move-overlay + caml-types-expr-ovl left right target-buf) + (setq limits + (caml-types-find-interval target-buf + target-pos node) + type (cdr (assoc "type" (elt node 2)))) )) + ) (setq mes (format "type: %s" type)) (insert type) )) diff --git a/experimental/garrigue/countchars.ml b/experimental/garrigue/countchars.ml new file mode 100644 index 0000000000..0f14d2fee8 --- /dev/null +++ b/experimental/garrigue/countchars.ml @@ -0,0 +1,16 @@ +let rec long_lines name n ic = + let l = input_line ic in + if String.length l > 80 then Printf.printf "%s: %d\n%!" name n; + long_lines name (n+1) ic + +let process_file name = + try + let ic = open_in name in + try long_lines name 1 ic + with End_of_file -> close_in ic + with _ ->() + +let () = + for i = 1 to Array.length Sys.argv - 1 do + process_file Sys.argv.(i) + done diff --git a/lex/lexer.mll b/lex/lexer.mll index b99dddf9e0..b3f61bae0e 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -36,10 +36,10 @@ let store_string_char c = Buffer.add_char string_buff c let get_stored_string () = Buffer.contents string_buff let char_for_backslash = function - 'n' -> '\n' - | 't' -> '\t' - | 'b' -> '\b' - | 'r' -> '\r' + 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' | c -> c let raise_lexical_error lexbuf msg = @@ -114,7 +114,7 @@ let identstart = let identbody = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let backslash_escapes = - ['\\' '"' '\'' 'n' 't' 'b' 'r'] + ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] rule main = parse [' ' '\013' '\009' '\012' ] + diff --git a/man/Makefile b/man/Makefile index 474a1c99cb..4c0cb81914 100644 --- a/man/Makefile +++ b/man/Makefile @@ -18,5 +18,6 @@ DIR=$(MANDIR)/man$(MANEXT) install: for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done - echo '.so man$(MANEXT)/jocamlc.$(MANEXT)' > $(DIR)/jocamlc.opt.$(MANEXT) - echo '.so man$(MANEXT)/jocamlopt.$(MANEXT)' > $(DIR)/jocamlopt.opt.$(MANEXT) + 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/ocamlc.m b/man/ocamlc.m index c26d29ca54..1de59fa70c 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -209,8 +209,8 @@ file can be used with the emacs commands given in to display types and other annotations interactively. .TP .B \-dtypes -Has been deprecated. Please use -.BI \-annot +Has been deprecated. Please use +.B \-annot instead. .TP .B \-c @@ -615,7 +615,7 @@ function type and is ignored. \ \ \ Label omitted in function application. 7 -\ \ \ Method overridden without using the "override" keyword +\ \ \ Method overridden without using the "method!" keyword 8 \ \ \ Partial match: missing cases in pattern-matching. @@ -747,7 +747,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-9\-27\-29\-32..37 . +.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. diff --git a/man/ocamlcp.m b/man/ocamlcp.m index 0c9979f108..25dcf28368 100644 --- a/man/ocamlcp.m +++ b/man/ocamlcp.m @@ -12,10 +12,10 @@ .\" .\" $Id$ .\" -.TH OCAMLCP 1 +.TH "OCAMLCP" 1 .SH NAME -ocamlcp \- The OCaml profiling compiler +ocamlcp, ocamloptp \- The OCaml profiling compilers .SH SYNOPSIS .B ocamlcp @@ -23,36 +23,62 @@ ocamlcp \- The OCaml 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 @@ -69,7 +95,7 @@ count points are set in both branches .TP .B l -\BR while , \ for +.BR while , \ for loops: a count point is set at the beginning of the loop body .TP .B m @@ -84,27 +110,31 @@ 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 OCaml user's manual" , diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 0dfb196bd6..c6037ae2df 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -151,7 +151,7 @@ If options are passed on the command line, these options are stored in the resulting .cmxa library. Then, linking with this library automatically adds back the -\BR \-cclib \ and \ \-ccopt +.BR \-cclib \ and \ \-ccopt options as if they had been provided on the command line, unless the .B \-noautolink diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 2cd3b64a01..19c55832e5 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,8 +1,8 @@ -odoc.cmo: ../typing/typedtree.cmi odoc_messages.cmo odoc_info.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.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 @@ -17,9 +17,9 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \ ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \ - ../utils/config.cmi ../utils/clflags.cmi ../utils/ccomp.cmi \ - odoc_analyse.cmi -odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ + ../utils/config.cmi ../typing/cmi_format.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 \ @@ -29,15 +29,15 @@ odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \ - ../utils/config.cmx ../utils/clflags.cmx ../utils/ccomp.cmx \ - odoc_analyse.cmi -odoc_args.cmo: odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \ + ../utils/config.cmx ../typing/cmi_format.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_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 \ +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 \ @@ -55,7 +55,7 @@ odoc_ast.cmx: ../typing/types.cmx ../typing/typedtree.cmx \ >>>>>>> .fusion-droit.r10497 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_global.cmo: odoc_comments_global.cmi odoc_comments_global.cmx: odoc_comments_global.cmi @@ -91,33 +91,35 @@ odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ odoc_class.cmo odoc_cross.cmi -odoc_cross.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ +odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ odoc_class.cmx odoc_cross.cmi -odoc_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_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_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_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_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 \ +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 \ +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_html.cmo : odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi >>>>>>> .fusion-droit.r10497 odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ @@ -141,22 +143,22 @@ odoc_inherit.cmx: >>>>>>> .fusion-droit.r10497 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_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_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_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_man.cmo : odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ odoc_info.cmi ../parsing/asttypes.cmi -odoc_man.cmx: odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ +odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ odoc_info.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_global.cmi odoc_exception.cmo odoc_class.cmo odoc_merge.cmi -odoc_merge.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ +odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi odoc_messages.cmo: ../utils/config.cmi @@ -165,7 +167,7 @@ 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.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \ @@ -178,7 +180,7 @@ odoc.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \ ../utils/misc.cmx ../utils/config.cmx ../utils/clflags.cmx 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 <<<<<<< .courant odoc_name.cmo: ../typing/path.cmi ../parsing/longident.cmi \ @@ -196,7 +198,7 @@ odoc_print.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_print.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: @@ -209,33 +211,35 @@ odoc_print.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi >>>>>>> .fusion-droit.r10497 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 ../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 ../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_see_lexer.cmo : odoc_parser.cmi +odoc_see_lexer.cmx : odoc_parser.cmx +odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ + ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \ + odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ + odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ + odoc_exception.cmo odoc_env.cmi odoc_class.cmo ../utils/misc.cmi \ + ../parsing/location.cmi ../typing/ident.cmi ../typing/btype.cmi \ + ../parsing/asttypes.cmi odoc_sig.cmi +odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ + ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \ + odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ + odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ + odoc_exception.cmx odoc_env.cmx odoc_class.cmx ../utils/misc.cmx \ + ../parsing/location.cmx ../typing/ident.cmx ../typing/btype.cmx \ + ../parsing/asttypes.cmi odoc_sig.cmi +odoc_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 @@ -249,7 +253,7 @@ odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_text_lexer.cmx: odoc_text_parser.cmx 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 \ <<<<<<< .courant odoc_text.cmi odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi @@ -267,13 +271,13 @@ odoc_to_text.cmx: odoc_module.cmx odoc_messages.cmx odoc_info.cmx >>>>>>> .fusion-droit.r10497 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 ../parsing/location.cmi odoc_types.cmi +odoc_types.cmx : odoc_messages.cmx ../parsing/location.cmx odoc_types.cmi +odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi -odoc_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_global.cmi odoc_args.cmi: odoc_gen.cmi @@ -301,19 +305,19 @@ odoc_global.cmi: odoc_types.cmi >>>>>>> .fusion-droit.r10497 odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ - odoc_global.cmi odoc_exception.cmo odoc_class.cmo -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 ../parsing/location.cmi +odoc_merge.cmi : odoc_types.cmi odoc_module.cmo +odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi +odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ ../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 : ../parsing/location.cmi diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 7fac63597c..ca8af3d40e 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -50,7 +50,9 @@ ODOC_TEST=odoc_test.cmo GENERATORS_CMOS= \ generators/odoc_todo.cmo \ generators/odoc_literate.cmo -GENERATORS_CMXS=$(GENERATORS_CMOS:.cmo=.cmxs) +GENERATORS_CMXS_TMP1=$(GENERATORS_CMOS:.cmo=.cmxs) +GENERATORS_CMXS_TMP2=$(NATDYNLINK:false=) +GENERATORS_CMXS=$(GENERATORS_CMXS_TMP2:true=$(GENERATORS_CMXS_TMP1)) # Compilation @@ -158,6 +160,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/typing/predef.cmo \ $(OCAMLSRCDIR)/typing/datarepr.cmo \ $(OCAMLSRCDIR)/typing/subst.cmo \ + $(OCAMLSRCDIR)/typing/cmi_format.cmo \ $(OCAMLSRCDIR)/typing/env.cmo \ $(OCAMLSRCDIR)/typing/ctype.cmo \ $(OCAMLSRCDIR)/typing/primitive.cmo \ @@ -170,6 +173,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/typing/stypes.cmo \ $(OCAMLSRCDIR)/typing/joinmatching.cmo \ $(OCAMLSRCDIR)/typing/typejoin.cmo \ + $(OCAMLSRCDIR)/typing/cmt_format.cmo \ $(OCAMLSRCDIR)/typing/typecore.cmo \ $(OCAMLSRCDIR)/typing/includeclass.cmo \ $(OCAMLSRCDIR)/typing/typedecl.cmo \ @@ -208,17 +212,17 @@ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) generatorsopt: $(GENERATORS_CMXS) debug: - make OCAMLPP="" + $(MAKE) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) - $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES) manpages: stdlib_man/Pervasives.3o @@ -309,6 +313,13 @@ test_stdlib: dummy ../otherlibs/unix/unix.mli \ ../otherlibs/str/str.mli +test_stdlib_code: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \ + `ls ../stdlib/*.ml | grep -v Labels` \ + ../otherlibs/unix/unix.ml \ + ../otherlibs/str/str.ml + test_framed: dummy $(MKDIR) $@ $(OCAMLDOC_RUN) -g odoc_fhtml.cmo -sort -colorize-code -d $@ $(INCLUDES) odoc*.ml odoc*.mli diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 7937bb261e..3113544dc8 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -148,6 +148,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/typing/predef.cmo \ $(OCAMLSRCDIR)/typing/datarepr.cmo \ $(OCAMLSRCDIR)/typing/subst.cmo \ + $(OCAMLSRCDIR)/typing/cmi_format.cmo \ $(OCAMLSRCDIR)/typing/env.cmo \ $(OCAMLSRCDIR)/typing/ctype.cmo \ $(OCAMLSRCDIR)/typing/primitive.cmo \ @@ -155,9 +156,10 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/typing/printtyp.cmo \ $(OCAMLSRCDIR)/typing/includecore.cmo \ $(OCAMLSRCDIR)/typing/typetexp.cmo \ - $(OCAMLSRCDIR)/typing/parmatch.cmo \ $(OCAMLSRCDIR)/typing/typedtree.cmo \ + $(OCAMLSRCDIR)/typing/parmatch.cmo \ $(OCAMLSRCDIR)/typing/stypes.cmo \ + $(OCAMLSRCDIR)/typing/cmt_format.cmo \ $(OCAMLSRCDIR)/typing/typecore.cmo \ $(OCAMLSRCDIR)/typing/includeclass.cmo \ $(OCAMLSRCDIR)/typing/typedecl.cmo \ @@ -185,7 +187,7 @@ opt.opt: exeopt libopt exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: - make OCAMLPP="" + $(MAKE) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index d717a9e2d9..7633d05682 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -45,7 +45,7 @@ let preprocess sourcefile = match !Clflags.preprocessor with None -> sourcefile | Some pp -> - let tmpfile = Filename.temp_file "camlpp" "" in + let tmpfile = Filename.temp_file "ocamldocpp" "" in let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in if Ccomp.command comm <> 0 then begin remove_file tmpfile; @@ -112,7 +112,10 @@ let process_implementation_file ppf sourcefile = let env = initial_env () in try let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in - let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in + let typedtree = + Typemod.type_implementation + sourcefile prefixname modulename env parsetree + in (Some (parsetree, typedtree), inputfile) with e -> @@ -163,6 +166,9 @@ let process_error exn = | Env.Error err -> Location.print_error_cur_file ppf; Env.report_error ppf err + | Cmi_format.Error err -> + Location.print_error_cur_file ppf; + Cmi_format.report_error ppf err | Ctype.Tags(l, l') -> Location.print_error_cur_file ppf; fprintf ppf @@ -250,8 +256,8 @@ let process_file ppf sourcefile = try let (ast, signat, input_file) = process_interface_file ppf file in let file_module = Sig_analyser.analyse_signature file - !Location.input_name ast signat - in + !Location.input_name ast signat.sig_type + in file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ; @@ -287,7 +293,7 @@ let process_file ppf sourcefile = let m = { Odoc_module.m_name = mod_name ; - Odoc_module.m_type = Types.Tmty_signature [] ; + Odoc_module.m_type = Types.Mty_signature [] ; Odoc_module.m_info = None ; Odoc_module.m_is_interface = true ; Odoc_module.m_file = file ; @@ -295,7 +301,7 @@ let process_file ppf sourcefile = [Odoc_module.Element_module_comment txt] ; Odoc_module.m_loc = { Odoc_types.loc_impl = None ; - Odoc_types.loc_inter = Some (file, 0) } ; + Odoc_types.loc_inter = Some (Location.in_file file) } ; Odoc_module.m_top_deps = [] ; Odoc_module.m_code = None ; Odoc_module.m_code_intf = None ; diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 7e26a876fc..46c185e50c 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -17,6 +17,96 @@ module M = Odoc_messages 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 [(character, _)] and a list of options. *) @@ -294,7 +384,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 := [ diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index 7881c0a395..0606eb0d70 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -174,6 +174,30 @@ val files : source_file list ref (** To set the documentation generator. *) val set_generator : Odoc_gen.generator -> unit +(** Extend current HTML generator. + @raise Failure if another kind of generator is already set.*) +val extend_html_generator : (module Odoc_gen.Html_functor) -> unit + +(** Extend current LaTeX generator. + @raise Failure if another kind of generator is already set.*) +val extend_latex_generator : (module Odoc_gen.Latex_functor) -> unit + +(** Extend current Texi generator. + @raise Failure if another kind of generator is already set.*) +val extend_texi_generator : (module Odoc_gen.Texi_functor) -> unit + +(** Extend current man generator. + @raise Failure if another kind of generator is already set.*) +val extend_man_generator : (module Odoc_gen.Man_functor) -> unit + +(** Extend current dot generator. + @raise Failure if another kind of generator is already set.*) +val extend_dot_generator : (module Odoc_gen.Dot_functor) -> 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 diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 62685135d4..d094f672f0 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -54,50 +54,50 @@ module Typedtree_search = | P of string | IM of string - type tab = (ele, Typedtree.structure_item) Hashtbl.t + type tab = (ele, Typedtree.structure_item_desc) Hashtbl.t type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t let iter_val_pattern = function | Typedtree.Tpat_any -> None - | Typedtree.Tpat_var name -> Some (Name.from_ident name) + | Typedtree.Tpat_var (name, _) -> Some (Name.from_ident name) | Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *) | _ -> None let add_to_hashes table table_values tt = match tt with - | Typedtree.Tstr_module (ident, _) -> + | Typedtree.Tstr_module (ident, _, _) -> Hashtbl.add table (M (Name.from_ident ident)) tt | Typedtree.Tstr_recmodule mods -> - List.iter - (fun (ident,mod_expr) -> - Hashtbl.add table (M (Name.from_ident ident)) - (Typedtree.Tstr_module (ident,mod_expr)) - ) - mods - | Typedtree.Tstr_modtype (ident, _) -> + List.iter + (fun (ident,ident_loc, _, mod_expr) -> + Hashtbl.add table (M (Name.from_ident ident)) + (Typedtree.Tstr_module (ident,ident_loc, mod_expr)) + ) + mods + | Typedtree.Tstr_modtype (ident, _, _) -> Hashtbl.add table (MT (Name.from_ident ident)) tt - | Typedtree.Tstr_exception (ident, _) -> + | Typedtree.Tstr_exception (ident, _, _) -> Hashtbl.add table (E (Name.from_ident ident)) tt - | Typedtree.Tstr_exn_rebind (ident, _) -> + | Typedtree.Tstr_exn_rebind (ident, _, _, _) -> Hashtbl.add table (ER (Name.from_ident ident)) tt | Typedtree.Tstr_type ident_type_decl_list -> List.iter - (fun (id, e) -> + (fun (id, id_loc, e) -> Hashtbl.add table (T (Name.from_ident id)) - (Typedtree.Tstr_type [(id,e)])) + (Typedtree.Tstr_type [(id,id_loc,e)])) ident_type_decl_list | Typedtree.Tstr_class info_list -> List.iter - (fun ((id,_,_,_) as ci) -> - Hashtbl.add table (C (Name.from_ident id)) - (Typedtree.Tstr_class [ci])) + (fun (ci, m, s) -> + Hashtbl.add table (C (Name.from_ident ci.ci_id_class)) + (Typedtree.Tstr_class [ci, m, s])) info_list - | Typedtree.Tstr_cltype info_list -> + | Typedtree.Tstr_class_type info_list -> List.iter - (fun ((id,_) as ci) -> + (fun ((id,id_loc,_) as ci) -> Hashtbl.add table (CT (Name.from_ident id)) - (Typedtree.Tstr_cltype [ci])) + (Typedtree.Tstr_class_type [ci])) info_list | Typedtree.Tstr_value (_, pat_exp_list) -> List.iter @@ -107,7 +107,7 @@ module Typedtree_search = | Some n -> Hashtbl.add table_values n (pat,exp) ) pat_exp_list - | Typedtree.Tstr_primitive (ident, _) -> + | Typedtree.Tstr_primitive (ident, _, _) -> Hashtbl.add table (P (Name.from_ident ident)) tt | Typedtree.Tstr_open _ -> () | Typedtree.Tstr_include _ -> () @@ -119,41 +119,42 @@ module Typedtree_search = let tables typedtree = let t = Hashtbl.create 13 in let t_values = Hashtbl.create 13 in - List.iter (add_to_hashes t t_values) typedtree; + List.iter (fun str -> add_to_hashes t t_values str.str_desc) typedtree; (t, t_values) let search_module table name = match Hashtbl.find table (M name) with - (Typedtree.Tstr_module (_, module_expr)) -> module_expr + (Typedtree.Tstr_module (_, _, module_expr)) -> module_expr | _ -> assert false let search_module_type table name = match Hashtbl.find table (MT name) with - | (Typedtree.Tstr_modtype (_, module_type)) -> module_type + | (Typedtree.Tstr_modtype (_, _, module_type)) -> module_type | _ -> assert false let search_exception table name = match Hashtbl.find table (E name) with - | (Typedtree.Tstr_exception (_, excep_decl)) -> excep_decl + | (Typedtree.Tstr_exception (_, _, excep_decl)) -> excep_decl | _ -> assert false let search_exception_rebind table name = match Hashtbl.find table (ER name) with - | (Typedtree.Tstr_exn_rebind (_, p)) -> p + | (Typedtree.Tstr_exn_rebind (_, _, p, _)) -> p | _ -> assert false let search_type_declaration table name = match Hashtbl.find table (T name) with - | (Typedtree.Tstr_type [(_,decl)]) -> decl + | (Typedtree.Tstr_type [(_,_, decl)]) -> decl | _ -> assert false let search_class_exp table name = match Hashtbl.find table (C name) with - | (Typedtree.Tstr_class [(_,_,_,ce)]) -> + | (Typedtree.Tstr_class [(ci, _, _ )]) -> + let ce = ci.ci_expr in ( try let type_decl = search_type_declaration table name in - (ce, type_decl.Types.type_params) + (ce, type_decl.typ_type.Types.type_params) with Not_found -> (ce, []) @@ -162,50 +163,50 @@ module Typedtree_search = let search_class_type_declaration table name = match Hashtbl.find table (CT name) with - | (Typedtree.Tstr_cltype [(_,cltype_decl)]) -> cltype_decl + | (Typedtree.Tstr_class_type [(_,_,cltype_decl)]) -> cltype_decl | _ -> assert false let search_value table name = Hashtbl.find table name let search_primitive table name = match Hashtbl.find table (P name) with - Tstr_primitive (ident, val_desc) -> val_desc.Types.val_type + Tstr_primitive (ident, _, val_desc) -> val_desc.val_val.Types.val_type | _ -> assert false let get_nth_inherit_class_expr cls n = let rec iter cpt = function | [] -> raise Not_found - | Typedtree.Cf_inher (clexp, _, _) :: q -> + | { cf_desc = Typedtree.Tcf_inher (_, clexp, _, _, _) } :: q -> if n = cpt then clexp else iter (cpt+1) q | _ :: q -> iter cpt q in - iter 0 cls.Typedtree.cl_field + iter 0 cls.Typedtree.cstr_fields let search_attribute_type cls name = let rec iter = function | [] -> raise Not_found - | Typedtree.Cf_val (_, ident, exp) :: q + | { cf_desc = Typedtree.Tcf_val (_, _, _, ident, Tcfk_concrete exp, _) } :: q when Name.from_ident ident = name -> exp.Typedtree.exp_type | _ :: q -> iter q in - iter cls.Typedtree.cl_field + iter cls.Typedtree.cstr_fields let class_sig_of_cltype_decl = let rec iter = function - Types.Tcty_constr (_, _, cty) -> iter cty - | Types.Tcty_signature s -> s - | Types.Tcty_fun (_,_, cty) -> iter cty + Types.Cty_constr (_, _, cty) -> iter cty + | Types.Cty_signature s -> s + | Types.Cty_fun (_,_, cty) -> iter cty in fun ct_decl -> iter ct_decl.Types.clty_type let search_virtual_attribute_type table ctname name = let ct_decl = search_class_type_declaration table ctname in - let cls_sig = class_sig_of_cltype_decl ct_decl in + let cls_sig = class_sig_of_cltype_decl ct_decl.ci_type_decl in let (_,_,texp) = Types.Vars.find name cls_sig.cty_vars in texp @@ -213,12 +214,12 @@ module Typedtree_search = let rec iter = function | [] -> raise Not_found - | Typedtree.Cf_meth (label, exp) :: q when label = name -> + | { cf_desc = Typedtree.Tcf_meth (label, _, _, Tcfk_concrete exp, _) } :: q when label = name -> exp | _ :: q -> iter q in - iter cls.Typedtree.cl_field + iter cls.Typedtree.cstr_fields end module Analyser = @@ -256,14 +257,14 @@ module Analyser = let tt_param_info_from_pattern env f_desc pat = let rec iter_pattern pat = match pat.pat_desc with - Typedtree.Tpat_var ident -> + Typedtree.Tpat_var (ident, _) -> let name = Name.from_ident ident in Simple_name { sn_name = name ; sn_text = f_desc name ; sn_type = Odoc_env.subst_type env pat.pat_type } - | Typedtree.Tpat_alias (pat, _) -> + | Typedtree.Tpat_alias (pat, _, _) -> iter_pattern pat | Typedtree.Tpat_tuple patlist -> @@ -271,7 +272,7 @@ module Analyser = (List.map iter_pattern patlist, Odoc_env.subst_type env pat.pat_type) - | Typedtree.Tpat_construct (cons_desc, _) when + | Typedtree.Tpat_construct (_, _, cons_desc, _, _) when (* we give a name to the parameter only if it unit *) (match cons_desc.cstr_res.desc with Tconstr (p, _, _) -> @@ -325,7 +326,7 @@ module Analyser = ( ( match func_body.exp_desc with - Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, func_body2) -> + Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var (id, _) } , exp) :: _, func_body2) -> let name = Name.from_ident id in let new_param = Simple_name { sn_name = name ; @@ -344,7 +345,7 @@ module Analyser = in (* continue if the body is still a function *) match next_exp.exp_desc with - Texp_function (pat_exp_list, _) -> + Texp_function (_, pat_exp_list, _) -> p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list) | _ -> (* something else ; no more parameter *) @@ -355,11 +356,18 @@ module Analyser = let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag = let (pat, exp) = pat_exp in match (pat.pat_desc, exp.exp_desc) with - (Typedtree.Tpat_var ident, Typedtree.Texp_function (pat_exp_list2, partial)) -> + (Typedtree.Tpat_var (ident, _), Typedtree.Texp_function (_, pat_exp_list2, partial)) -> (* a new function is defined *) 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 ; @@ -367,25 +375,32 @@ 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_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + val_code = code ; + val_loc = { loc_impl = Some loc ; loc_inter = None } ; } in [ new_value ] - | (Typedtree.Tpat_var ident, _) -> + | (Typedtree.Tpat_var (ident, _), _) -> (* a new value is defined *) 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_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + val_code = code ; + val_loc = { loc_impl = Some loc ; loc_inter = None } ; } in [ new_value ] @@ -414,9 +429,9 @@ module Analyser = ); *) match clexp.Typedtree.cl_desc with - Typedtree.Tclass_ident p -> Name.from_path p - | Typedtree.Tclass_constraint (class_expr, _, _, _) - | Typedtree.Tclass_apply (class_expr, _) -> tt_name_of_class_expr class_expr + Typedtree.Tcl_ident (p, _, _) -> Name.from_path p + | Typedtree.Tcl_constraint (class_expr, _, _, _, _) + | Typedtree.Tcl_apply (class_expr, _) -> tt_name_of_class_expr class_expr (* | Typedtree.Tclass_fun (_, _, class_expr, _) -> tt_name_of_class_expr class_expr | Typedtree.Tclass_let (_,_,_, class_expr) -> tt_name_of_class_expr class_expr @@ -430,7 +445,7 @@ module Analyser = *) let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = match exp.Typedtree.exp_desc with - Typedtree.Texp_function (pat_exp_list, _) -> + Typedtree.Texp_function (_, pat_exp_list, _) -> ( match pat_exp_list with [] -> @@ -440,7 +455,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 *) @@ -470,7 +485,7 @@ module Analyser = ( ( match body.exp_desc with - Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, body2) -> + Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var (id, _) } , exp) :: _, body2) -> let name = Name.from_ident id in let new_param = Simple_name { sn_name = name ; @@ -516,8 +531,10 @@ module Analyser = ele_coms in (acc_inher, acc_fields @ ele_comments) - - | (Parsetree.Pcf_inher (_, p_clexp, _)) :: q -> + | item :: q -> + let loc = item.Parsetree.pcf_loc in + match item.Parsetree.pcf_desc with + | (Parsetree.Pcf_inher (_, p_clexp, _)) -> let tt_clexp = let n = List.length acc_inher in try Typedtree_search.get_nth_inherit_class_expr tt_cls n @@ -544,113 +561,135 @@ module Analyser = p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q - | ((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 = + | ((Parsetree.Pcf_val ({ txt = label }, mutable_flag, _, _) | + Parsetree.Pcf_valvirt ({ txt = label }, mutable_flag, _) ) as x) -> + let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let type_exp = try 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 - - | (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 = + 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 loc ; 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 ({ txt = label }, private_flag, _)) -> + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let met_type = + try Odoc_sig.Signature_search.search_method_type label tt_class_sig + with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label)) + in + let real_type = 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 loc ; 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 = + | (Parsetree.Pcf_meth ({ txt = label }, private_flag, _, _)) -> + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let exp = 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 loc ; 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 -> + | Parsetree.Pcf_constr (_, _) -> (* don't give a $*%@ ! *) iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q - | (Parsetree.Pcf_init exp) :: q -> + | (Parsetree.Pcf_init exp) -> iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q in - iter [] [] last_pos (snd p_cls) + iter [] [] last_pos (p_cls.Parsetree.pcstr_fields) (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *) let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp table = @@ -658,17 +697,17 @@ module Analyser = (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) -> let name = match tt_class_exp_desc with - Typedtree.Tclass_ident p -> Name.from_path p + Typedtree.Tcl_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 *) - Name.from_longident lid + (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *) + Name.from_longident lid.txt 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 - Types.Tcty_constr (p2, type_exp_list, cltyp) -> + Types.Cty_constr (p2, type_exp_list, cltyp) -> (* cltyp is the class type for [type_exp_list] p *) type_exp_list | _ -> @@ -682,11 +721,11 @@ module Analyser = cco_type_parameters = List.map (Odoc_env.subst_type env) params ; } ) - | (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) -> + | (Parsetree.Pcl_structure p_class_structure, Typedtree.Tcl_structure tt_class_structure) -> (* we need the class signature to get the type of methods in analyse_class_structure *) let tt_class_sig = match tt_class_exp.Typedtree.cl_type with - Types.Tcty_signature class_sig -> class_sig + Types.Cty_signature class_sig -> class_sig | _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.") in let (inherited_classes, class_elements) = analyse_class_structure @@ -703,16 +742,16 @@ module Analyser = Class_structure (inherited_classes, class_elements) ) | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2), - Typedtree.Tclass_fun (pat, ident_exp_list, tt_class_expr2, partial)) -> + Typedtree.Tcl_fun (_, pat, ident_exp_list, tt_class_expr2, partial)) -> (* we check that this is not an optional parameter with a default value. In this case, we look for the good parameter pattern *) let (parameter, next_tt_class_exp) = match pat.Typedtree.pat_desc with - Typedtree.Tpat_var ident when Name.from_ident ident = "*opt*" -> + Typedtree.Tpat_var (ident, _) when Name.from_ident ident = "*opt*" -> ( - (* there must be a Tclass_let just after *) + (* there must be a Tcl_let just after *) match tt_class_expr2.Typedtree.cl_desc with - Typedtree.Tclass_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, _, tt_class_expr3) -> + Typedtree.Tcl_let (_, ({pat_desc = Typedtree.Tpat_var (id,_) } , exp) :: _, _, tt_class_expr3) -> let name = Name.from_ident id in let new_param = Simple_name { sn_name = name ; @@ -742,23 +781,23 @@ module Analyser = in (parameter :: params, k) - | (Parsetree.Pcl_apply (p_class_expr2, _), Tclass_apply (tt_class_expr2, exp_opt_optional_list)) -> + | (Parsetree.Pcl_apply (p_class_expr2, _), Tcl_apply (tt_class_expr2, exp_opt_optional_list)) -> let applied_name = (* we want an ident, or else the class applied will appear in the form object ... end, because if the class applied has no name, the code is kinda ugly, isn't it ? *) match tt_class_expr2.Typedtree.cl_desc with - Typedtree.Tclass_ident p -> Name.from_path p (* A VOIR : obtenir le nom complet *) + Typedtree.Tcl_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. *) - Name.from_longident lid + Name.from_longident lid.txt | _ -> Odoc_messages.object_end in let param_exps = List.fold_left - (fun acc -> fun (exp_opt, _) -> + (fun acc -> fun (_, exp_opt, _) -> match exp_opt with None -> acc | Some e -> acc @ [e]) @@ -781,14 +820,14 @@ module Analyser = capp_params_code = params_code ; } ) - | (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tclass_let (_, _, _, tt_class_expr2)) -> + | (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tcl_let (_, _, _, tt_class_expr2)) -> (* we don't care about these lets *) analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 table | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2), - Typedtree.Tclass_constraint (tt_class_expr2, _, _, _)) -> + Typedtree.Tcl_constraint (tt_class_expr2, _, _, _, _)) -> let (l, class_kind) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 table @@ -813,8 +852,9 @@ module Analyser = (** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*) let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp table = let name = p_class_decl.Parsetree.pci_name in - let complete_name = Name.concat current_module_name name in - let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in + let complete_name = Name.concat current_module_name name.txt in + let loc = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc in + let pos_start = loc.Location.loc_start.Lexing.pos_cnum in let type_parameters = tt_type_params in let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in @@ -836,7 +876,7 @@ module Analyser = cl_type_parameters = type_parameters ; cl_kind = kind ; cl_parameters = parameters ; - cl_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ; + cl_loc = { loc_impl = Some loc ; loc_inter = None } ; } in cl @@ -845,8 +885,8 @@ module Analyser = is not an ident of a constraint on an ident. *) let rec tt_name_from_module_expr mod_expr = match mod_expr.Typedtree.mod_desc with - Typedtree.Tmod_ident p -> Name.from_path p - | Typedtree.Tmod_constraint (m_exp, _, _) -> tt_name_from_module_expr m_exp + Typedtree.Tmod_ident (p,_) -> Name.from_path p + | Typedtree.Tmod_constraint (m_exp, _, _, _) -> tt_name_from_module_expr m_exp | Typedtree.Tmod_structure _ | Typedtree.Tmod_functor _ | Typedtree.Tmod_apply _ @@ -856,7 +896,7 @@ module Analyser = (** Get the list of included modules in a module structure of a typed tree. *) let tt_get_included_module_list tt_structure = let f acc item = - match item with + match item.str_desc with Typedtree.Tstr_include (mod_expr, _) -> acc @ [ { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *) @@ -868,7 +908,7 @@ module Analyser = | _ -> acc in - List.fold_left f [] tt_structure + List.fold_left f [] tt_structure.str_items (** This function takes a [module element list] of a module and replaces the "dummy" included modules with the ones found in typed tree structure of the module. *) @@ -886,10 +926,98 @@ module Analyser = in f (module_elements, included_modules) + (** This function removes the elements of the module which does not + belong to the given module type, if the module type is expanded + and the module has a "structure" kind. *) + let rec filter_module_with_module_type_constraint m mt = + match m.m_kind, mt with + Module_struct l, Types.Mty_signature lsig -> + m.m_kind <- Module_struct (filter_module_elements_with_module_type_constraint l lsig); + m.m_type <- mt; + | _ -> () + + (** This function removes the elements of the module type which does not + belong to the given module type, if the module type is expanded + and the module type has a "structure" kind. *) + and filter_module_type_with_module_type_constraint mtyp mt = + match mtyp.mt_kind, mt with + Some Module_type_struct l, Types.Mty_signature lsig -> + mtyp.mt_kind <- Some (Module_type_struct (filter_module_elements_with_module_type_constraint l lsig)); + mtyp.mt_type <- Some mt; + | _ -> () + + and filter_module_elements_with_module_type_constraint l lsig = + let pred ele = + let f = match ele with + Element_module m -> + (function + Types.Sig_module (ident,t,_) -> + let n1 = Name.simple m.m_name + and n2 = Ident.name ident in + ( + match n1 = n2 with + true -> filter_module_with_module_type_constraint m t; true + | false -> false + ) + | _ -> false) + | Element_module_type mt -> + (function + Types.Sig_modtype (ident,Types.Modtype_manifest t) -> + let n1 = Name.simple mt.mt_name + and n2 = Ident.name ident in + ( + match n1 = n2 with + true -> filter_module_type_with_module_type_constraint mt t; true + | false -> false + ) + | _ -> false) + | Element_value v -> + (function + Types.Sig_value (ident,_) -> + let n1 = Name.simple v.val_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_type t -> + (function + Types.Sig_type (ident,_,_) -> + (* 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 + | _ -> false) + | Element_exception e -> + (function + Types.Sig_exception (ident,_) -> + let n1 = Name.simple e.ex_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_class c -> + (function + Types.Sig_class (ident,_,_) -> + let n1 = Name.simple c.cl_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_class_type ct -> + (function + Types.Sig_class_type (ident,_,_) -> + let n1 = Name.simple ct.clt_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + | Element_module_comment _ -> fun _ -> true + | Element_included_module _ -> fun _ -> true + in + List.exists f lsig + in + List.filter pred l + (** Analysis of a parse tree structure with a typed tree, to return module elements.*) let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree = print_DEBUG "Odoc_ast:analyse_struture"; - let (table, table_values) = Typedtree_search.tables typedtree in + let (table, table_values) = Typedtree_search.tables typedtree.str_items in let rec iter env last_pos = function [] -> let s = get_string_of_file last_pos pos_limit in @@ -962,7 +1090,7 @@ module Analyser = iter new_last_pos acc_env acc q | Some name -> try - let pat_exp = Typedtree_search.search_value table_values name in + let pat_exp = Typedtree_search.search_value table_values name.txt in let (info_opt, ele_comments) = (* we already have the optional comment for the first value. *) if first then @@ -1000,116 +1128,125 @@ module Analyser = let (new_env, l_ele) = iter ~first: true loc.Location.loc_start.Lexing.pos_cnum env [] pat_exp_list in (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]) + | Parsetree.Pstr_primitive ({ txt = 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 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 loc ; 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 - (fun acc_env -> fun (name, _) -> - let complete_name = Name.concat current_module_name name in - Odoc_env.add_type acc_env complete_name + | Parsetree.Pstr_type name_typedecl_list -> + (* of (string * type_declaration) list *) + (* we start by extending the environment *) + let new_env = + List.fold_left + (fun acc_env -> fun ({ txt = name }, _) -> + let complete_name = Name.concat current_module_name name in + Odoc_env.add_type acc_env complete_name ) 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, []) + | ({ txt = name }, type_decl) :: q -> + let complete_name = Name.concat current_module_name name in + let loc = type_decl.Parsetree.ptype_loc in + let loc_start = loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let pos_limit2 = match q with - [] -> pos_limit - | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum - 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 tt_type_decl = tt_type_decl.Typedtree.typ_type 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 = - List.map2 - (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) - tt_type_decl.Types.type_params - tt_type_decl.Types.type_variance ; - 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 = + 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) + ) + 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 loc ; loc_inter = None } ; + ty_code = ( 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 *) - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in (* we get the exception declaration in the typed tree *) let tt_excep_decl = - try Typedtree_search.search_exception table name + try Typedtree_search.search_exception table name.txt with Not_found -> raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) in @@ -1120,9 +1257,11 @@ module Analyser = { ex_name = complete_name ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl.exn_args ; + ex_args = List.map (fun ctyp -> + Odoc_env.subst_type new_env ctyp.ctyp_type) + tt_excep_decl.exn_params ; ex_alias = None ; - ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + ex_loc = { loc_impl = Some loc ; loc_inter = None } ; ex_code = ( if !Odoc_global.keep_code then @@ -1134,12 +1273,12 @@ module Analyser = in (0, new_env, [ Element_exception new_ex ]) - | Parsetree.Pstr_exn_rebind (name, _) -> + | Parsetree.Pstr_exn_rebind (name, _) -> (* a new exception is defined *) - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in (* we get the exception rebind in the typed tree *) let tt_path = - try Typedtree_search.search_exception_rebind table name + try Typedtree_search.search_exception_rebind table name.txt with Not_found -> raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) in @@ -1151,7 +1290,7 @@ module Analyser = ex_args = [] ; ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ; ea_ex = None ; } ; - ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + ex_loc = { loc_impl = Some loc ; loc_inter = None } ; ex_code = None ; } in @@ -1161,11 +1300,11 @@ module Analyser = ( (* of string * module_expr *) try - let tt_module_expr = Typedtree_search.search_module table name in + let tt_module_expr = Typedtree_search.search_module table name.txt in let new_module_pre = analyse_module env current_module_name - name + name.txt comment_opt module_expr tt_module_expr @@ -1185,8 +1324,8 @@ 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 *) - Types.Tmty_signature s -> + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Mty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s | _ -> @@ -1195,7 +1334,7 @@ module Analyser = (0, new_env2, [ Element_module new_module ]) with Not_found -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) ) @@ -1205,22 +1344,22 @@ module Analyser = let new_env = List.fold_left (fun acc_env (name, _, mod_exp) -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let e = Odoc_env.add_module acc_env complete_name in let tt_mod_exp = - try Typedtree_search.search_module table name + try Typedtree_search.search_module table name.txt with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) in let new_module = analyse_module e current_module_name - name + name.txt None mod_exp tt_mod_exp in match new_module.m_type with - Types.Tmty_signature s -> + Types.Mty_signature s -> Odoc_env.add_signature e new_module.m_name ~rel: (Name.simple new_module.m_name) s | _ -> @@ -1233,11 +1372,11 @@ module Analyser = match name_mod_exp_list with [] -> [] | (name, _, mod_exp) :: q -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in let tt_mod_exp = - try Typedtree_search.search_module table name + try Typedtree_search.search_module table name.txt with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) in let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) @@ -1249,7 +1388,7 @@ module Analyser = let new_module = analyse_module new_env current_module_name - name + name.txt com_opt mod_exp tt_mod_exp @@ -1261,31 +1400,31 @@ module Analyser = (0, new_env, eles) | Parsetree.Pstr_modtype (name, modtype) -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let tt_module_type = - try Typedtree_search.search_module_type table name + try Typedtree_search.search_module_type table name.txt with Not_found -> raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name)) in let kind = Sig.analyse_module_type_kind env complete_name - modtype tt_module_type + modtype tt_module_type.mty_type in let mt = { mt_name = complete_name ; mt_info = comment_opt ; - mt_type = Some tt_module_type ; + mt_type = Some tt_module_type.mty_type ; mt_is_interface = false ; mt_file = !file_name ; mt_kind = Some kind ; - mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; + mt_loc = { loc_impl = Some loc ; loc_inter = None } ; } in 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 *) - Types.Tmty_signature s -> + match tt_module_type.mty_type with + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *) + Types.Mty_signature s -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s | _ -> new_env @@ -1308,7 +1447,7 @@ module Analyser = let new_env = List.fold_left (fun acc_env -> fun class_decl -> - let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name.txt in Odoc_env.add_class acc_env complete_name ) env @@ -1320,9 +1459,9 @@ module Analyser = [] | class_decl :: q -> let (tt_class_exp, tt_type_params) = - try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name + try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name.txt with Not_found -> - let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name.txt in raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name)) in let (com_opt, ele_comments) = @@ -1350,7 +1489,7 @@ module Analyser = let new_env = List.fold_left (fun acc_env -> fun class_type_decl -> - let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name.txt in Odoc_env.add_class_type acc_env complete_name ) env @@ -1362,13 +1501,14 @@ module Analyser = [] | class_type_decl :: q -> let name = class_type_decl.Parsetree.pci_name in - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let virt = class_type_decl.Parsetree.pci_virt = Asttypes.Virtual in let tt_cltype_declaration = - try Typedtree_search.search_class_type_declaration table name + try Typedtree_search.search_class_type_declaration table name.txt with Not_found -> raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name)) - in + in + let tt_cltype_declaration = tt_cltype_declaration.ci_type_decl in let type_params = tt_cltype_declaration.Types.clty_params in let kind = Sig.analyse_class_type_kind new_env @@ -1393,7 +1533,7 @@ module Analyser = clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ; clt_virtual = virt ; clt_kind = kind ; - clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; + clt_loc = { loc_impl = Some loc ; loc_inter = None } ; } in @@ -1412,15 +1552,16 @@ 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.Pstr_def _ | Parsetree.Pstr_exn_global _ -> assert false (** 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 = let complete_name = Name.concat current_module_name module_name in - let pos_start = p_module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in - let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in + let loc = p_module_expr.Parsetree.pmod_loc in + let pos_start = loc.Location.loc_start.Lexing.pos_cnum in + let pos_end = loc.Location.loc_end.Lexing.pos_cnum in let modtype = (* A VOIR : Odoc_env.subst_module_type env ? *) tt_module_expr.Typedtree.mod_type @@ -1442,14 +1583,14 @@ module Analyser = m_is_interface = false ; m_file = !file_name ; m_kind = Module_struct [] ; - m_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ; + m_loc = { loc_impl = Some loc ; loc_inter = None } ; m_top_deps = [] ; m_code = None ; (* code is set by the caller, after the module is created *) m_code_intf = m_code_intf ; } in match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with - (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident path) -> + (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident (path, _)) -> let alias_name = Odoc_env.full_module_name env (Name.from_path path) in { m_base with m_kind = Module_alias { ma_name = alias_name ; ma_module = None ; } } @@ -1462,19 +1603,19 @@ module Analyser = { m_base with m_kind = Module_struct elements2 } | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2), - Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) -> + Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) -> let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in - let mp_type_code = get_string_of_file loc_start loc_end in - print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); - let mp_name = Name.from_ident ident in - let mp_kind = Sig.analyse_module_type_kind env - current_module_name pmodule_type mtyp - in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_name = Name.from_ident ident in + let mp_kind = Sig.analyse_module_type_kind env + current_module_name pmodule_type mtyp.mty_type + in let param = { mp_name = mp_name ; - mp_type = Odoc_env.subst_module_type env mtyp ; + mp_type = Odoc_env.subst_module_type env mtyp.mty_type ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; } @@ -1497,7 +1638,7 @@ module Analyser = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)) | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), Typedtree.Tmod_constraint - ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)}, + ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)}, _, _, _) ) -> let m1 = analyse_module @@ -1519,7 +1660,7 @@ module Analyser = { m_base with m_kind = Module_apply (m1.m_kind, m2.m_kind) } | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype), - Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _)) -> + Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _, _)) -> print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name); (* we create the module with p_module_expr2 and tt_module_expr2 @@ -1555,10 +1696,10 @@ module Analyser = | (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_constraint - ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure}, - tt_modtype, _) - ) -> - (* needed for recursive modules *) + ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure}, + tt_modtype, _, _) + ) -> + (* needed for recursive modules *) print_DEBUG ("Odoc_ast: case Parsetree.Pmod_structure + Typedtree.Tmod_constraint "^module_name); let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in @@ -1570,7 +1711,7 @@ module Analyser = m_kind = Module_struct elements2 ; } - | (Parsetree.Pmod_unpack (p_exp), + | (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 = @@ -1584,7 +1725,7 @@ module Analyser = (* 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 -> + | Mty_ident p -> Odoc_env.full_module_type_name env (Name.from_path p) | _ -> "" in @@ -1666,12 +1807,12 @@ module Analyser = let kind = Module_struct elements2 in { m_name = mod_name ; - m_type = Types.Tmty_signature [] ; + m_type = Types.Mty_signature [] ; m_info = info_opt ; m_is_interface = false ; m_file = !file_name ; m_kind = kind ; - m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; + m_loc = { loc_impl = Some (Location.in_file !file_name) ; loc_inter = None } ; m_top_deps = [] ; m_code = (if !Odoc_global.keep_code then Some !file else None) ; m_code_intf = None ; diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli index 48ba98bfb3..d7c111f85b 100644 --- a/ocamldoc/odoc_ast.mli +++ b/ocamldoc/odoc_ast.mli @@ -20,7 +20,7 @@ module Typedtree_search : sig type ele - type tab = (ele, Typedtree.structure_item) Hashtbl.t + type tab = (ele, Typedtree.structure_item_desc) Hashtbl.t type tab_values = (Odoc_name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t (** Create hash tables used to search by some of the functions below. *) @@ -34,12 +34,12 @@ module Typedtree_search : (** This function returns the [Types.module_type] associated to the given module type name, in the given table. @raise Not_found if the module type was not found.*) - val search_module_type : tab -> string -> Types.module_type + val search_module_type : tab -> string -> Typedtree.module_type (** This function returns the [Types.exception_declaration] associated to the given exception name, in the given table. @raise Not_found if the exception was not found.*) - val search_exception : tab -> string -> Types.exception_declaration + val search_exception : tab -> string -> Typedtree.exception_declaration (** This function returns the [Path.t] associated to the given exception rebind name, in the table. @@ -49,7 +49,7 @@ module Typedtree_search : (** This function returns the [Typedtree.type_declaration] associated to the given type name, in the given table. @raise Not_found if the type was not found. *) - val search_type_declaration : tab -> string -> Types.type_declaration + val search_type_declaration : tab -> string -> Typedtree.type_declaration (** This function returns the [Typedtree.class_expr] and type parameters associated to the given class name, in the given table. @@ -59,7 +59,7 @@ module Typedtree_search : (** This function returns the [Types.cltype_declaration] associated to the given class type name, in the given table. @raise Not_found if the class type was not found. *) - val search_class_type_declaration : tab -> string -> Types.cltype_declaration + val search_class_type_declaration : tab -> string -> Typedtree.class_type_declaration (** This function returns the couple (pat, exp) for the given value name, in the given table of values. diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml index 676d0ebc37..28abf67031 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 bee9882365..9d6e5fc89c 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 6e505157e0..535c5381ec 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 @@ -250,12 +256,17 @@ class scan = method! scan_value v = >>>>>>> .fusion-droit.r10497 add_known_element v.val_name (Odoc_search.Res_value v) -<<<<<<< .courant - method scan_type t = -======= - method! scan_type t = ->>>>>>> .fusion-droit.r10497 - 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 = @@ -640,7 +651,23 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_ let ao = Odoc_misc.apply_opt -let rec assoc_comments_text_elements module_list t_ele = +let not_found_of_kind kind name = + (match kind with + RK_module -> Odoc_messages.cross_module_not_found + | RK_module_type -> Odoc_messages.cross_module_type_not_found + | RK_class -> Odoc_messages.cross_class_not_found + | RK_class_type -> Odoc_messages.cross_class_type_not_found + | RK_value -> Odoc_messages.cross_value_not_found + | RK_type -> Odoc_messages.cross_type_not_found + | RK_exception -> Odoc_messages.cross_exception_not_found + | 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 = match t_ele with | Raw _ | Code _ @@ -735,6 +762,10 @@ let rec assoc_comments_text_elements 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) @@ -841,6 +872,8 @@ let rec assoc_comments_text_elements 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 ( diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index a108cf416a..3ab89192d0 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -51,30 +51,30 @@ let rec add_signature env root ?rel signat = in let f env item = match item with - Types.Tsig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } - | Types.Tsig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } - | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } - | Types.Tsig_module (ident, modtype, _) -> + Types.Sig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } + | Types.Sig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } + | Types.Sig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } + | Types.Sig_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 *) - Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s + match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) + Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s | _ -> env in { env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules } - | Types.Tsig_modtype (ident, modtype_decl) -> + | Types.Sig_modtype (ident, modtype_decl) -> let env2 = match modtype_decl with - Types.Tmodtype_abstract -> + Types.Modtype_abstract -> env - | Types.Tmodtype_manifest modtype -> + | Types.Modtype_manifest modtype -> 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 + (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) + Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s | _ -> env in { env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types } - | Types.Tsig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } - | Types.Tsig_cltype (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } + | Types.Sig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } + | Types.Sig_class_type (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } in List.fold_left f env signat @@ -218,31 +218,31 @@ let subst_type env t = let subst_module_type env t = let rec iter t = match t with - Types.Tmty_ident p -> + Types.Mty_ident p -> let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in - Types.Tmty_ident new_p - | Types.Tmty_signature _ -> + Types.Mty_ident new_p + | Types.Mty_signature _ -> t - | Types.Tmty_functor (id, mt1, mt2) -> - Types.Tmty_functor (id, iter mt1, iter mt2) + | Types.Mty_functor (id, mt1, mt2) -> + Types.Mty_functor (id, iter mt1, iter mt2) in iter t let subst_class_type env t = let rec iter t = match t with - Types.Tcty_constr (p,texp_list,ct) -> + Types.Cty_constr (p,texp_list,ct) -> let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in let new_texp_list = List.map (subst_type env) texp_list in let new_ct = iter ct in - Types.Tcty_constr (new_p, new_texp_list, new_ct) - | Types.Tcty_signature cs -> + Types.Cty_constr (new_p, new_texp_list, new_ct) + | Types.Cty_signature cs -> (* on ne s'occupe pas des vals et methods *) t - | Types.Tcty_fun (l, texp, ct) -> + | Types.Cty_fun (l, texp, ct) -> let new_texp = subst_type env texp in let new_ct = iter ct in - Types.Tcty_fun (l, new_texp, new_ct) + Types.Cty_fun (l, new_texp, new_ct) in iter t diff --git a/ocamldoc/odoc_gen.ml b/ocamldoc/odoc_gen.ml index b77b186d4c..b1909e786d 100644 --- a/ocamldoc/odoc_gen.ml +++ b/ocamldoc/odoc_gen.ml @@ -18,13 +18,24 @@ 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) - | Other of (module Base) + | Base of (module Base) ;; let get_minimal_generator = function @@ -43,7 +54,7 @@ let get_minimal_generator = function | Dot m -> let module M = (val m : Odoc_dot.Dot_generator) in (new M.dot :> doc_generator) -| Other m -> +| Base m -> let module M = (val m : Base) in new M.generator ;; diff --git a/ocamldoc/odoc_gen.mli b/ocamldoc/odoc_gen.mli index 4649c9504b..37768c008d 100644 --- a/ocamldoc/odoc_gen.mli +++ b/ocamldoc/odoc_gen.mli @@ -20,6 +20,15 @@ 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) @@ -27,7 +36,7 @@ type generator = | Texi of (module Odoc_texi.Texi_generator) | Man of (module Odoc_man.Man_generator) | Dot of (module Odoc_dot.Dot_generator) - | Other of (module Base) + | Base of (module Base) ;; val get_minimal_generator : generator -> doc_generator diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index e66ede145e..22f25cf016 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -37,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" @@ -89,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) @@ -312,22 +331,18 @@ class virtual text = in fun b s -> if !colorize_code then - ( - bs b "<pre></pre>"; - self#html_of_code b (remove_useless_newlines s); - bs b "<pre></pre>" - ) + self#html_of_code b (remove_useless_newlines s) else ( - bs b "<pre><code class=\""; - bs b Odoc_ocamlhtml.code_class; - bs b "\">" ; - bs b (self#escape (remove_useless_newlines s)); - bs b "</code></pre>" - ) + bs b "<pre class=\"codepre\"><code class=\""; + bs b Odoc_ocamlhtml.code_class; + bs b "\">" ; + bs b (self#escape (remove_useless_newlines s)); + bs b "</code></pre>" + ) method html_of_Verbatim b s = - bs b "<pre>"; + bs b "<pre class=\"verbatim\">"; bs b (self#escape s); bs b "</pre>" @@ -436,6 +451,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 @@ -462,7 +479,7 @@ class virtual text = bs b "<br>\n<table class=\"indextable\">\n"; List.iter (fun name -> - bs b "<tr><td>"; + bs b "<tr><td class=\"module\">"; ( try let m = @@ -486,8 +503,9 @@ class virtual text = let index_if_not_empty l url m = match l with [] -> () - | _ -> bp b "<a href=\"%s\">%s</a><br>\n" url m + | _ -> bp b "<li><a href=\"%s\">%s</a></li>\n" url m in + bp b "<ul class=\"indexlist\">\n"; index_if_not_empty self#list_types self#index_types Odoc_messages.index_of_types; index_if_not_empty self#list_exceptions self#index_exceptions Odoc_messages.index_of_exceptions; index_if_not_empty self#list_values self#index_values Odoc_messages.index_of_values; @@ -496,7 +514,8 @@ class virtual text = index_if_not_empty self#list_classes self#index_classes Odoc_messages.index_of_classes; index_if_not_empty self#list_class_types self#index_class_types Odoc_messages.index_of_class_types; index_if_not_empty self#list_modules self#index_modules Odoc_messages.index_of_modules; - index_if_not_empty self#list_module_types self#index_module_types Odoc_messages.index_of_module_types + index_if_not_empty self#list_module_types self#index_module_types Odoc_messages.index_of_module_types; + bp b "</ul>\n" method virtual list_types : Odoc_info.Type.t_type list method virtual index_types : string @@ -686,7 +705,7 @@ class virtual info = let module M = Odoc_info in let dep = info.M.i_deprecated <> None in bs b "<div class=\"info\">\n"; - if dep then bs b "<font color=\"#CCCCCC\">"; + if dep then bs b "<span class=\"deprecated\">"; ( match info.M.i_desc with None -> () @@ -697,7 +716,7 @@ class virtual info = (Odoc_info.first_sentence_of_text d)); bs b "\n" ); - if dep then bs b "</font>"; + if dep then bs b "</span>"; bs b "</div>\n" end @@ -744,11 +763,7 @@ class html = (** The default style options. *) val mutable 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 }" ; + [ ".keyword { font-weight : bold ; color : Red }" ; ".keywordsign { color : #C04600 }" ; ".superscript { font-size : 4 }" ; ".subscript { font-size : 4 }" ; @@ -757,9 +772,18 @@ class html = ".type { color : #5C6585 }" ; ".string { color : Maroon }" ; ".warning { color : Red ; font-weight : bold }" ; - ".info { margin-left : 3em; margin-right : 3em }" ; + ".info { margin-left : 3em; margin-right: 3em }" ; ".param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }" ; ".code { color : #465F91 ; }" ; + ".typetable { border-style : hidden }" ; + ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ; + "tr { background-color : White }" ; + "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ; + "div.sig_block {margin-left: 2em}" ; + "*:target { background: yellow; }" ; + + "body {font: 13px sans-serif; color: black; text-align: left; padding: 5px; margin: 0}"; + "h1 { font-size : 20pt ; text-align: center; }" ; "h2 { font-size : 20pt ; border: 1px solid #000000; "^ @@ -782,10 +806,10 @@ class html = "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; }" ; + "h6 { font-size : 20pt ; border: 1px solid #000000; "^ + "margin-top: 5px; margin-bottom: 2px;"^ + "text-align: center; background-color: #90BDFF ; "^ + "padding: 2px; }" ; "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^ "margin-top: 5px; margin-bottom: 2px;"^ @@ -802,17 +826,22 @@ class html = "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 }" ; + "a {color: #416DFF; text-decoration: none}"; + "a:hover {background-color: #ddd; text-decoration: underline}"; + "pre { margin-bottom: 4px; font-family: monospace; }" ; + "pre.verbatim, pre.codepre { }"; + + ".indextable {border: 1px #ddd solid; border-collapse: collapse}"; + ".indextable td, .indextable th {border: 1px #ddd solid; min-width: 80px}"; + ".indextable td.module {background-color: #eee ; padding-left: 2px; padding-right: 2px}"; + ".indextable td.module a {color: 4E6272; text-decoration: none; display: block; width: 100%}"; + ".indextable td.module a:hover {text-decoration: underline; background-color: transparent}"; + ".deprecated {color: #888; font-style: italic}" ; - "div.sig_block {margin-left: 2em}" ; + ".indextable tr td div.info { margin-left: 2px; margin-right: 2px }" ; - "*:target { background: yellow; } " ; + "ul.indexlist { margin-left: 0; padding-left: 0;}"; + "ul.indexlist li { list-style-type: none ; margin-left: 0; padding-left: 0; }"; ] (** The style file for all pages. *) @@ -1045,22 +1074,25 @@ class html = match pre with None -> () | Some name -> - bp b "<a href=\"%s\">%s</a>\n" - (fst (Naming.html_files name)) - Odoc_messages.previous + bp b "<a class=\"pre\" href=\"%s\" title=\"%s\">%s</a>\n" + (fst (Naming.html_files name)) + name + Odoc_messages.previous ); bs b " "; let father = Name.father name in let href = if father = "" then self#index else fst (Naming.html_files father) in - bp b "<a href=\"%s\">%s</a>\n" href Odoc_messages.up; + let father_name = if father = "" then "Index" else father in + bp b "<a class=\"up\" href=\"%s\" title=\"%s\">%s</a>\n" href father_name Odoc_messages.up; bs b " "; ( match post with None -> () | Some name -> - bp b "<a href=\"%s\">%s</a>\n" - (fst (Naming.html_files name)) - Odoc_messages.next + bp b "<a class=\"post\" href=\"%s\" title=\"%s\">%s</a>\n" + (fst (Naming.html_files name)) + name + Odoc_messages.next ); bs b "</div>\n" @@ -1237,11 +1269,11 @@ 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é *) - self#html_of_module_type_kind b father ?modu k; - bs b "<code class=\"type\"> "; - bs b (self#create_fully_qualified_module_idents_links father s); - bs b "</code>" + (* TODO: modify when Module_with will be more detailed *) + self#html_of_module_type_kind b father ?modu k; + bs b "<code class=\"type\"> "; + bs b (self#create_fully_qualified_module_idents_links father s); + bs b "</code>" | Module_constraint (k, tk) -> (* TODO: on affiche quoi ? *) self#html_of_module_kind b father ?modu k @@ -1417,14 +1449,14 @@ class html = Odoc_info.reset_type_names (); let father = Name.father t.ty_name in bs b - (match t.ty_manifest, t.ty_kind with - None, Type_abstract -> "<pre>" - | None, Type_variant _ - | None, Type_record _ -> "<br><code>" - | Some _, Type_abstract -> "<pre>" - | Some _, Type_variant _ - | Some _, Type_record _ -> "<pre>" - ); + (match t.ty_manifest, t.ty_kind with + None, Type_abstract -> "<pre>" + | None, Type_variant _ + | None, Type_record _ -> "<pre><code>" + | Some _, Type_abstract -> "<pre>" + | Some _, Type_variant _ + | Some _, Type_record _ -> "<pre>" + ); bp b "<span id=\"%s\">" (Naming.type_target t); bs b ((self#keyword "type")^" "); self#html_of_type_expr_param_list b father t; @@ -1449,7 +1481,7 @@ class html = bs b ( match t.ty_manifest with - None -> "</code>" + None -> "</code></pre>" | Some _ -> "</pre>" ); bs b "<table class=\"typetable\">\n"; @@ -1459,7 +1491,9 @@ class html = bs b (self#keyword "|"); bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n"; bs b "<code>"; - bs b (self#constructor constr.vc_name); + bp b "<span id=\"%s\">%s</span>" + (Naming.const_target t constr) + (self#constructor constr.vc_name); ( match constr.vc_args, constr.vc_ret with [], None -> () @@ -1473,7 +1507,7 @@ class html = 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; + self#html_of_type_expr b father r; ); bs b "</code></td>\n"; ( @@ -1499,14 +1533,14 @@ class html = | Type_record l -> bs b "= "; - if priv then bs b "private " ; - bs b "{"; - bs b - ( - match t.ty_manifest with - None -> "</code>" - | Some _ -> "</pre>" - ); + if priv then bs b "private " ; + bs b "{"; + bs b + ( + match t.ty_manifest with + None -> "</code></pre>" + | Some _ -> "</pre>" + ); bs b "<table class=\"typetable\">\n" ; let print_one r = bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; @@ -1514,7 +1548,9 @@ class html = bs b "</td>\n<td align=\"left\" valign=\"top\" >\n"; bs b "<code>"; if r.rf_mutable then bs b (self#keyword "mutable ") ; - bs b (r.rf_name ^ " : ") ; + bp b "<span id=\"%s\">%s</span> :" + (Naming.recfield_target t r) + r.rf_name; self#html_of_type_expr b father r.rf_type; bs b ";</code></td>\n"; ( @@ -1827,8 +1863,8 @@ class html = self#html_of_text b [Code "end"] | Class_apply capp -> - (* TODO: afficher le type final à partir du typedtree *) - self#html_of_text b [Raw "class application not handled yet"] + (* TODO: display final type from typedtree *) + self#html_of_text b [Raw "class application not handled yet"] | Class_constr cco -> ( @@ -2078,9 +2114,11 @@ class html = let b = new_buf () in bs b "<html>\n"; self#print_header b (self#inner_title title); - bs b "<body>\n<center><h1>"; - bs b title; - bs b "</h1></center>\n" ; + bs b "<body>\n"; + self#print_navbar b None None ""; + bs b "<h1>"; + bs b title; + bs b "</h1>\n" ; let sorted_elements = List.sort (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) @@ -2113,7 +2151,7 @@ class html = in bs b "<table>\n"; List.iter f_group groups ; - bs b "</table><br>\n" ; + bs b "</table>\n" ; bs b "</body>\n</html>"; Buffer.output_buffer chanout b; close_out chanout @@ -2151,11 +2189,11 @@ class html = (self#inner_title cl.cl_name); bs b "<body>\n"; self#print_navbar b pre_name post_name cl.cl_name; - bs b "<center><h1>"; + bs b "<h1>"; bs b (Odoc_messages.clas^" "); if cl.cl_virtual then bs b "virtual " ; bp b "<a href=\"%s\">%s</a>" type_file cl.cl_name; - bs b "</h1></center>\n<br>\n"; + bs b "</h1>\n"; self#html_of_class b ~with_link: false cl; (* parameters *) self#html_of_described_parameter_list b @@ -2198,11 +2236,11 @@ class html = bs b "<body>\n"; self#print_navbar b pre_name post_name clt.clt_name; - bs b "<center><h1>"; + bs b "<h1>"; bs b (Odoc_messages.class_type^" "); if clt.clt_virtual then bs b "virtual "; bp b "<a href=\"%s\">%s</a>" type_file clt.clt_name; - bs b "</h1></center>\n<br>\n"; + bs b "</h1>\n"; self#html_of_class_type b ~with_link: false clt; (* class inheritance *) @@ -2242,14 +2280,14 @@ class html = (self#inner_title mt.mt_name); bs b "<body>\n"; self#print_navbar b pre_name post_name mt.mt_name; - bp b "<center><h1>"; + bp b "<h1>"; bs b (Odoc_messages.module_type^" "); ( match mt.mt_type with Some _ -> bp b "<a href=\"%s\">%s</a>" type_file mt.mt_name | None-> bs b mt.mt_name ); - bs b "</h1></center>\n<br>\n" ; + bs b "</h1>\n" ; self#html_of_modtype b ~with_link: false mt; (* parameters for functors *) @@ -2309,7 +2347,7 @@ class html = (self#inner_title modu.m_name); bs b "<body>\n" ; self#print_navbar b pre_name post_name modu.m_name ; - bs b "<center><h1>"; + bs b "<h1>"; bs b ( if Module.module_is_functor modu then @@ -2323,7 +2361,7 @@ class html = None -> () | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file ); - bs b "</h1></center>\n<br>\n"; + bs b "</h1>\n"; self#html_of_module b ~with_link: false modu; @@ -2380,9 +2418,10 @@ class html = bs b "<html>\n"; self#print_header b self#title; bs b "<body>\n"; - bs b "<center><h1>"; + + bs b "<h1>"; bs b title; - bs b "</h1></center>\n" ; + bs b "</h1>\n" ; let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) !Odoc_info.Global.intro_file diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml index 4d0033d044..c087646e7d 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 @@ -80,8 +82,8 @@ type info = Odoc_types.info = { } type location = Odoc_types.location = { - loc_impl : (string * int) option ; - loc_inter : (string * int) option ; + loc_impl : Location.t option ; + loc_inter : Location.t option ; } let dummy_loc = { loc_impl = None ; loc_inter = None } @@ -317,6 +319,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 diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index ffd164b6fc..f8eae5210b 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. *) @@ -97,8 +99,8 @@ type info = Odoc_types.info = { (** Location of elements in implementation and interface files. *) type location = Odoc_types.location = { - loc_impl : (string * int) option ; (** implementation file name and position *) - loc_inter : (string * int) option ; (** interface file name and position *) + loc_impl : Location.t option ; (** implementation location *) + loc_inter : Location.t option ; (** interface location *) } (** A dummy location. *) @@ -786,6 +788,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 @@ -830,6 +834,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 diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 07a66783fd..e40a74142d 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -37,6 +37,7 @@ let latex_titles = ref [ let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix +let latex_type_elt_prefix = ref Odoc_messages.default_latex_type_elt_prefix let latex_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 @@ -97,19 +98,19 @@ class text = "}", "\\\\}"; "\\$", "\\\\$"; "\\^", "{\\\\textasciicircum}"; - "à", "\\\\`a"; - "â", "\\\\^a"; - "é", "\\\\'e"; - "è", "\\\\`e"; - "ê", "\\\\^e"; - "ë", "\\\\\"e"; - "ç", "\\\\c{c}"; - "ô", "\\\\^o"; - "ö", "\\\\\"o"; - "î", "\\\\^i"; - "ï", "\\\\\"i"; - "ù", "\\\\`u"; - "û", "\\\\^u"; + "à ", "\\\\`a"; + "â", "\\\\^a"; + "é", "\\\\'e"; + "è", "\\\\`e"; + "ê", "\\\\^e"; + "ë", "\\\\\"e"; + "ç", "\\\\c{c}"; + "ô", "\\\\^o"; + "ö", "\\\\\"o"; + "î", "\\\\^i"; + "ï", "\\\\\"i"; + "ù", "\\\\`u"; + "û", "\\\\^u"; "%", "\\\\%"; "_", "\\\\_"; "~", "\\\\~{}"; @@ -241,6 +242,12 @@ class text = (** Make a correct label from a type 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^"}" @@ -413,6 +420,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 @@ -577,7 +586,7 @@ class latex = ":" (self#normal_type_list ~par: false mod_name " * " l) "->" - (self#normal_type mod_name r) + (self#normal_type mod_name r) ); flush2 () in @@ -714,12 +723,12 @@ 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é *) - self#latex_of_module_type_kind fmt father k; - self#latex_of_text fmt - [ Code " "; - Code (self#relative_idents father s) ; - ] + (* TODO: à modifier quand Module_with sera plus détaillé *) + self#latex_of_module_type_kind fmt father k; + self#latex_of_text fmt + [ Code " "; + Code (self#relative_idents father s) ; + ] | Module_constraint (k, tk) -> (* TODO: on affiche quoi ? *) self#latex_of_module_kind fmt father k @@ -743,9 +752,9 @@ class latex = self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] | Class_apply capp -> - (* TODO: afficher le type final à partir du typedtree *) - self#latex_of_text fmt [Raw "class application not handled yet"] - + (* TODO: afficher le type final à partir du typedtree *) + self#latex_of_text fmt [Raw "class application not handled yet"] + | Class_constr cco -> ( match cco.cco_type_parameters with diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 49a24f47f8..8bafcea4d5 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -475,10 +475,10 @@ class man = bs b "(* "; self#man_of_text b t; bs b " *)\n " - | [], None, Some r -> + | [], None, Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; - bs b " " + bs b " " | [], (Some t), Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; @@ -996,6 +996,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 @@ -1037,6 +1039,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 diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli index 4f580ee899..3133c5e939 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 825dd42492..01429961cb 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -127,6 +127,11 @@ let latex_type_prefix = "<string>\n\t\tUse <string> 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 = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^ + "\t\t(default is \""^default_latex_type_elt_prefix^"\")" + let default_latex_exception_prefix = "exception:" let latex_exception_prefix = "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^ @@ -244,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." @@ -294,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 = "Attribute "^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 fdb1f789d6..561874d730 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -324,7 +324,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 diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index d18de47db7..a180cc7827 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -238,10 +238,10 @@ let rec module_elements ?(trans=true) m = | Module_constraint (k, tk) -> print_DEBUG "Odoc_module.module_element: Module_constraint"; (* A VOIR : utiliser k ou tk ? *) - module_elements ~trans: trans - { m_name = "" ; - m_info = None ; - m_type = Types.Tmty_signature [] ; + module_elements ~trans: trans + { m_name = "" ; + m_info = None ; + m_type = Types.Mty_signature [] ; m_is_interface = false ; m_file = "" ; m_kind = k ; m_loc = Odoc_types.dummy_loc ; m_top_deps = [] ; diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index f08a88fb97..8f64708a5d 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -214,4 +214,10 @@ let to_path n = None -> raise (Failure "to_path") | Some p -> p -let from_longident longident = String.concat "." (Longident.flatten longident) +let from_longident = Odoc_misc.string_of_longident + +module Set = Set.Make (struct + type z = t + type t = z + let compare = String.compare +end) diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli index e3b43a7867..9bff7c22ff 100644 --- a/ocamldoc/odoc_name.mli +++ b/ocamldoc/odoc_name.mli @@ -67,3 +67,6 @@ val to_path : t -> Path.t (** Get a name from a [Longident.t].*) val from_longident : Longident.t -> t + +(** Set of Name.t *) +module Set : Set.S with type elt = t diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index 5cc8e038c7..4083d1a7c7 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -55,15 +55,15 @@ exception Use_code of string let simpl_module_type ?code t = let rec iter t = match t with - Types.Tmty_ident p -> t - | Types.Tmty_signature _ -> + Types.Mty_ident p -> t + | Types.Mty_signature _ -> ( match code with - None -> Types.Tmty_signature [] + None -> Types.Mty_signature [] | Some s -> raise (Use_code s) ) - | Types.Tmty_functor (id, mt1, mt2) -> - Types.Tmty_functor (id, iter mt1, iter mt2) + | Types.Mty_functor (id, mt1, mt2) -> + Types.Mty_functor (id, iter mt1, iter mt2) in iter t @@ -80,20 +80,20 @@ let string_of_module_type ?code ?(complete=false) t = let simpl_class_type t = let rec iter 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 + Types.Cty_constr (p,texp_list,ct) -> t + | Types.Cty_signature cs -> + (* 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 + Types.Cty_signature { Types.cty_self = { cs.Types.cty_self with Types.desc = Types.Tobject (tnil, ref None) }; Types.cty_vars = Types.Vars.empty ; Types.cty_concr = Types.Concr.empty ; Types.cty_inher = [] } - | Types.Tcty_fun (l, texp, ct) -> + | Types.Cty_fun (l, texp, ct) -> let new_ct = iter ct in - Types.Tcty_fun (l, texp, new_ct) + Types.Cty_fun (l, texp, new_ct) in iter t diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml index 29e1ca2724..18a8f117c2 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 d6c58f7131..485e131561 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 @@ -95,7 +99,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 [] @@ -308,7 +331,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 @@ -325,7 +354,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 @@ -350,7 +381,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 @@ -375,7 +408,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 @@ -400,7 +435,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 @@ -425,7 +462,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 @@ -450,7 +489,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 @@ -475,7 +516,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 @@ -500,7 +543,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 @@ -525,7 +570,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 d7ace5831a..2f882d5246 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 d3cf80acc8..095210c604 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -47,19 +47,19 @@ module Signature_search = let add_to_hash table signat = match signat with - Types.Tsig_value (ident, _) -> + Types.Sig_value (ident, _) -> Hashtbl.add table (V (Name.from_ident ident)) signat - | Types.Tsig_exception (ident, _) -> + | Types.Sig_exception (ident, _) -> Hashtbl.add table (E (Name.from_ident ident)) signat - | Types.Tsig_type (ident, _, _) -> + | Types.Sig_type (ident, _, _) -> Hashtbl.add table (T (Name.from_ident ident)) signat - | Types.Tsig_class (ident, _, _) -> + | Types.Sig_class (ident, _, _) -> Hashtbl.add table (C (Name.from_ident ident)) signat - | Types.Tsig_cltype (ident, _, _) -> + | Types.Sig_class_type (ident, _, _) -> Hashtbl.add table (CT (Name.from_ident ident)) signat - | Types.Tsig_module (ident, _, _) -> + | Types.Sig_module (ident, _, _) -> Hashtbl.add table (M (Name.from_ident ident)) signat - | Types.Tsig_modtype (ident,_) -> + | Types.Sig_modtype (ident,_) -> Hashtbl.add table (MT (Name.from_ident ident)) signat let table signat = @@ -69,40 +69,40 @@ module Signature_search = let search_value table name = match Hashtbl.find table (V name) with - | (Types.Tsig_value (_, val_desc)) -> val_desc.Types.val_type + | (Types.Sig_value (_, val_desc)) -> val_desc.Types.val_type | _ -> assert false let search_exception table name = match Hashtbl.find table (E name) with - | (Types.Tsig_exception (_, type_expr_list)) -> + | (Types.Sig_exception (_, type_expr_list)) -> type_expr_list | _ -> assert false let search_type table name = match Hashtbl.find table (T name) with - | (Types.Tsig_type (_, type_decl, _)) -> type_decl + | (Types.Sig_type (_, type_decl, _)) -> type_decl | _ -> assert false let search_class table name = match Hashtbl.find table (C name) with - | (Types.Tsig_class (_, class_decl, _)) -> class_decl + | (Types.Sig_class (_, class_decl, _)) -> class_decl | _ -> assert false let search_class_type table name = match Hashtbl.find table (CT name) with - | (Types.Tsig_cltype (_, cltype_decl, _)) -> cltype_decl + | (Types.Sig_class_type (_, cltype_decl, _)) -> cltype_decl | _ -> assert false let search_module table name = match Hashtbl.find table (M name) with - | (Types.Tsig_module (ident, module_type, _)) -> module_type + | (Types.Sig_module (ident, module_type, _)) -> module_type | _ -> assert false let search_module_type table name = match Hashtbl.find table (MT name) with - | (Types.Tsig_modtype (_, Types.Tmodtype_manifest module_type)) -> + | (Types.Sig_modtype (_, Types.Modtype_manifest module_type)) -> Some module_type - | (Types.Tsig_modtype (_, Types.Tmodtype_abstract)) -> + | (Types.Sig_modtype (_, Types.Modtype_abstract)) -> None | _ -> assert false @@ -185,14 +185,14 @@ module Analyser = pos_limit in let (len, comment_opt) = My_ir.just_after_special !file_name s in - (len, acc @ [ (name, comment_opt) ]) + (len, acc @ [ (name.txt, comment_opt) ]) | (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]) + 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.txt, comment_opt]) ((name2, core_type_list2, ret_type2, loc2) :: q) in f [] cons_core_type_list_list @@ -205,13 +205,13 @@ module Analyser = let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file pos pos_end in let (_,comment_opt) = My_ir.just_after_special !file_name s in - [name, comment_opt] + [name.txt, comment_opt] | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q -> let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos pos2 in let (_,comment_opt) = My_ir.just_after_special !file_name s in - (name, comment_opt) :: (f (ele2 :: q)) + (name.txt, comment_opt) :: (f (ele2 :: q)) in (0, f name_mutable_type_list) @@ -221,6 +221,7 @@ module Analyser = Odoc_type.Type_abstract | Types.Type_variant l -> let f (constructor_name, type_expr_list, ret_type) = + let constructor_name = Ident.name constructor_name in let comment_opt = try match List.assoc constructor_name name_comment_list with @@ -239,6 +240,7 @@ module Analyser = | Types.Type_record (l, _) -> let f (field_name, mutable_flag, type_expr) = + let field_name = Ident.name field_name in let comment_opt = try match List.assoc field_name name_comment_list with @@ -255,6 +257,38 @@ module Analyser = in Odoc_type.Type_record (List.map f l) + let erased_names_of_constraints constraints acc = + List.fold_right (fun (longident, constraint_) acc -> + match constraint_ with + | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc + | Parsetree.Pwith_typesubst _ | Parsetree.Pwith_modsubst _ -> + Name.Set.add (Name.from_longident longident.txt) acc) + constraints acc + + let filter_out_erased_items_from_signature erased signature = + if Name.Set.is_empty erased then signature + else List.fold_right (fun sig_item acc -> + let take_item psig_desc = { sig_item with Parsetree.psig_desc } :: acc in + match sig_item.Parsetree.psig_desc with + | Parsetree.Psig_value (_, _) + | Parsetree.Psig_exception (_, _) + | Parsetree.Psig_open _ + | Parsetree.Psig_include _ + | Parsetree.Psig_class _ + | Parsetree.Psig_class_type _ as tp -> take_item tp + | Parsetree.Psig_type types -> + (match List.filter (fun (name, _) -> not (Name.Set.mem name.txt erased)) types with + | [] -> acc + | types -> take_item (Parsetree.Psig_type types)) + | Parsetree.Psig_module (name, _) + | Parsetree.Psig_modtype (name, _) as m -> + if Name.Set.mem name.txt erased then acc else take_item m + | Parsetree.Psig_recmodule mods -> + (match List.filter (fun (name, _) -> not (Name.Set.mem name.txt erased)) mods with + | [] -> acc + | mods -> take_item (Parsetree.Psig_recmodule mods))) + signature [] + (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) let analyse_class_elements env current_class_name last_pos pos_limit @@ -262,12 +296,13 @@ module Analyser = let get_pos_limit2 q = match q with [] -> pos_limit - | ele2 :: _ -> - match ele2 with - Parsetree.Pctf_val (_, _, _, loc) - | Parsetree.Pctf_virt (_, _, _, loc) - | Parsetree.Pctf_meth (_, _, _, loc) - | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum + | ele2 :: _ -> + let loc = ele2.Parsetree.pctf_loc in + match ele2.Parsetree.pctf_desc with + Parsetree.Pctf_val (_, _, _, _) + | Parsetree.Pctf_virt (_, _, _) + | Parsetree.Pctf_meth (_, _, _) + | Parsetree.Pctf_cstr (_, _) -> loc.Location.loc_start.Lexing.pos_cnum | Parsetree.Pctf_inher class_type -> class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum in @@ -289,7 +324,7 @@ module Analyser = val_recursive = false ; val_parameters = Odoc_value.dummy_parameter_list subst_typ ; val_code = None ; - val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) }; + val_loc = { loc_impl = None ; loc_inter = Some loc }; } ; met_private = private_flag = Asttypes.Private ; met_virtual = false ; @@ -325,7 +360,11 @@ module Analyser = in ([], ele_comments) - | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _, loc) :: q -> + | item :: q -> + let loc = item.Parsetree.pctf_loc in + match item.Parsetree.pctf_desc with + + | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _) -> (* 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 @@ -345,7 +384,7 @@ module Analyser = val_recursive = false ; val_parameters = [] ; val_code = None ; - val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ; + val_loc = { loc_impl = None ; loc_inter = Some loc} ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; att_virtual = virtual_flag = Asttypes.Virtual ; @@ -362,7 +401,7 @@ module Analyser = let (inher_l, eles) = f (pos_end + maybe_more) q in (inher_l, eles_comments @ ((Class_attribute att) :: eles)) - | Parsetree.Pctf_virt (name, private_flag, _, loc) :: q -> + | Parsetree.Pctf_virt (name, private_flag, _) -> (* of (string * private_flag * core_type * Location.t) *) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (met, maybe_more) = get_method name comment_opt private_flag loc q in @@ -370,21 +409,21 @@ module Analyser = let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in (inher_l, eles_comments @ ((Class_method met2) :: eles)) - | Parsetree.Pctf_meth (name, private_flag, _, loc) :: q -> + | Parsetree.Pctf_meth (name, private_flag, _) -> (* of (string * private_flag * core_type * Location.t) *) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (met, maybe_more) = get_method name comment_opt private_flag loc q in let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in (inher_l, eles_comments @ ((Class_method met) :: eles)) - | (Parsetree.Pctf_cstr (_, _, loc)) :: q -> + | (Parsetree.Pctf_cstr (_, _)) -> (* of (core_type * core_type * Location.t) *) (* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in (inher_l, eles_comments @ eles) - | Parsetree.Pctf_inher class_type :: q -> + | Parsetree.Pctf_inher class_type -> let loc = class_type.Parsetree.pcty_loc in let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum @@ -402,7 +441,7 @@ module Analyser = match class_type.Parsetree.pcty_desc with Parsetree.Pcty_constr (longident, _) -> (*of Longident.t * core_type list*) - let name = Name.from_longident longident in + let name = Name.from_longident longident.txt in let ic = { ic_name = Odoc_env.full_class_or_class_type_name env name ; @@ -414,7 +453,7 @@ module Analyser = | Parsetree.Pcty_signature _ | Parsetree.Pcty_fun _ -> - (* we don't have a name for the class signature, so we call it "object ... end" *) + (* we don't have a name for the class signature, so we call it "object ... end" *) { ic_name = Odoc_messages.object_end ; ic_class = None ; @@ -459,6 +498,7 @@ module Analyser = signat table current_module_name + ele.Parsetree.psig_loc ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum (match q with @@ -481,15 +521,15 @@ module Analyser = (** Analyse the given signature_item_desc to create the corresponding module element (with the given attached comment).*) and analyse_signature_item_desc env signat table current_module_name - pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = + sig_item_loc pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = match sig_item_desc with Parsetree.Psig_value (name_pre, value_desc) -> let type_expr = - try Signature_search.search_value table name_pre + try Signature_search.search_value table name_pre.txt with Not_found -> - raise (Failure (Odoc_messages.value_not_found current_module_name name_pre)) + raise (Failure (Odoc_messages.value_not_found current_module_name name_pre.txt)) in - let name = Name.parens_if_infix name_pre in + let name = Name.parens_if_infix name_pre.txt in let subst_typ = Odoc_env.subst_type env type_expr in let v = { @@ -499,7 +539,7 @@ module Analyser = val_recursive = false ; val_parameters = Odoc_value.dummy_parameter_list subst_typ ; val_code = None ; - val_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele)} + val_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; } in let (maybe_more, info_after_opt) = @@ -516,17 +556,17 @@ module Analyser = | Parsetree.Psig_exception (name, exception_decl) -> let types_excep_decl = - try Signature_search.search_exception table name + try Signature_search.search_exception table name.txt with Not_found -> - raise (Failure (Odoc_messages.exception_not_found current_module_name name)) + raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt)) in let e = { - ex_name = Name.concat current_module_name name ; + ex_name = Name.concat current_module_name name.txt ; ex_info = comment_opt ; ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ; ex_alias = None ; - ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ex_code = ( if !Odoc_global.keep_code then @@ -550,7 +590,7 @@ module Analyser = let new_env = List.fold_left (fun acc_env -> fun (name, _) -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in Odoc_env.add_type acc_env complete_name ) env @@ -572,7 +612,7 @@ module Analyser = let pos_limit2 = match q with [] -> pos_limit - | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum + | ( _, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let (maybe_more, name_comment_list) = name_comment_from_type_kind @@ -580,14 +620,14 @@ module Analyser = pos_limit2 type_decl.Parsetree.ptype_kind in - print_DEBUG ("Type "^name^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)); + print_DEBUG ("Type "^name.txt^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)); let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in List.iter f_DEBUG name_comment_list; (* get the information for the type in the signature *) let sig_type_decl = - try Signature_search.search_type table name + try Signature_search.search_type table name.txt with Not_found -> - raise (Failure (Odoc_messages.type_not_found current_module_name name)) + raise (Failure (Odoc_messages.type_not_found current_module_name name.txt)) in (* get the type kind with the associated comments *) let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in @@ -596,7 +636,7 @@ module Analyser = (* associate the comments to each constructor and build the [Type.t_type] *) let new_type = { - ty_name = Name.concat current_module_name name ; + ty_name = Name.concat current_module_name name.txt ; ty_info = assoc_com ; ty_parameters = List.map2 (fun p (co,cn,_) -> @@ -611,10 +651,7 @@ module Analyser = (match sig_type_decl.Types.type_manifest with None -> None | Some t -> Some (Odoc_env.subst_type new_env t)); - ty_loc = - { loc_impl = None ; - loc_inter = Some (!file_name,loc_start) ; - }; + ty_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ty_code = ( if !Odoc_global.keep_code then @@ -651,12 +688,12 @@ module Analyser = (0, env, ele_comments) | Parsetree.Psig_module (name, module_type) -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in (* get the the module type in the signature by the module name *) let sig_module_type = - try Signature_search.search_module table name + try Signature_search.search_module table name.txt with Not_found -> - raise (Failure (Odoc_messages.module_not_found current_module_name name)) + raise (Failure (Odoc_messages.module_not_found current_module_name name.txt)) in let module_kind = analyse_module_kind env complete_name module_type sig_module_type in let code_intf = @@ -676,7 +713,7 @@ module Analyser = m_is_interface = true ; m_file = !file_name ; m_kind = module_kind ; - m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + m_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; @@ -690,8 +727,8 @@ 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 *) - Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s + match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Mty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s | _ -> new_env in (maybe_more, new_env2, [ Element_module new_module ]) @@ -700,7 +737,7 @@ module Analyser = (* we start by extending the environment *) let new_env = List.fold_left - (fun acc_env -> fun (name, _) -> + (fun acc_env -> fun ({ txt = name }, _) -> let complete_name = Name.concat current_module_name name in let e = Odoc_env.add_module acc_env complete_name in (* get the information for the module in the signature *) @@ -710,8 +747,8 @@ 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 *) - Types.Tmty_signature s -> + (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Types.Mty_signature s -> Odoc_env.add_signature e complete_name ~rel: name s | _ -> print_DEBUG "not a Tmty_signature"; @@ -725,9 +762,10 @@ module Analyser = [] -> (acc_maybe_more, []) | (name, modtype) :: q -> - let complete_name = Name.concat current_module_name name in - let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in - let loc_end = modtype.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let complete_name = Name.concat current_module_name name.txt in + let loc = modtype.Parsetree.pmty_loc in + let loc_start = loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = loc.Location.loc_end.Lexing.pos_cnum in let (assoc_com, ele_comments) = if first then (comment_opt, []) @@ -739,19 +777,18 @@ module Analyser = let pos_limit2 = match q with [] -> pos_limit - | (_, mty) :: _ -> mty.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum + | (_, mty) :: _ -> loc.Location.loc_start.Lexing.pos_cnum in (* get the information for the module in the signature *) let sig_module_type = - try Signature_search.search_module table name + try Signature_search.search_module table name.txt with Not_found -> - raise (Failure (Odoc_messages.module_not_found current_module_name name)) + raise (Failure (Odoc_messages.module_not_found current_module_name name.txt)) in (* 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_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 Some (get_string_of_file st en) @@ -766,7 +803,7 @@ module Analyser = m_is_interface = true ; m_file = !file_name ; m_kind = module_kind ; - m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + m_loc = { loc_impl = None ; loc_inter = Some loc } ; m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; @@ -790,11 +827,11 @@ module Analyser = (maybe_more, new_env, mods) | Parsetree.Psig_modtype (name, pmodtype_decl) -> - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let sig_mtype = - try Signature_search.search_module_type table name + try Signature_search.search_module_type table name.txt with Not_found -> - raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) + raise (Failure (Odoc_messages.module_type_not_found current_module_name name.txt)) in let module_type_kind = match pmodtype_decl with @@ -813,7 +850,7 @@ module Analyser = mt_is_interface = true ; mt_file = !file_name ; mt_kind = module_type_kind ; - mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + mt_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; } in let (maybe_more, info_after_opt) = @@ -824,8 +861,8 @@ 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 *) - Some (Types.Tmty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s + match sig_mtype with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) + Some (Types.Mty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s | _ -> new_env in (maybe_more, new_env2, [ Element_module_type mt ]) @@ -833,7 +870,7 @@ module Analyser = | Parsetree.Psig_include module_type -> let rec f = function Parsetree.Pmty_ident longident -> - Name.from_longident longident + Name.from_longident longident.txt | Parsetree.Pmty_signature _ -> "??" | Parsetree.Pmty_functor _ -> @@ -842,7 +879,7 @@ module Analyser = f mt.Parsetree.pmty_desc | Parsetree.Pmty_typeof mexpr -> match mexpr.Parsetree.pmod_desc with - Parsetree.Pmod_ident longident -> Name.from_longident longident + Parsetree.Pmod_ident longident -> Name.from_longident longident.txt | _ -> "??" in <<<<<<< .courant @@ -859,14 +896,14 @@ 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 *) let new_env = List.fold_left (fun acc_env -> fun class_desc -> - let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name in + let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name.txt in Odoc_env.add_class acc_env complete_name ) env @@ -892,11 +929,11 @@ module Analyser = | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum in let name = class_desc.Parsetree.pci_name in - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let sig_class_decl = - try Signature_search.search_class table name + try Signature_search.search_class table name.txt with Not_found -> - raise (Failure (Odoc_messages.class_not_found current_module_name name)) + raise (Failure (Odoc_messages.class_not_found current_module_name name.txt)) in let sig_class_type = sig_class_decl.Types.cty_type in let (parameters, class_kind) = @@ -916,7 +953,7 @@ module Analyser = cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ; cl_kind = class_kind ; cl_parameters = parameters ; - cl_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + cl_loc = { loc_impl = None ; loc_inter = Some class_desc.Parsetree.pci_loc } ; } in let (maybe_more, info_after_opt) = @@ -942,7 +979,7 @@ module Analyser = let new_env = List.fold_left (fun acc_env -> fun class_type_decl -> - let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in + let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name.txt in Odoc_env.add_class_type acc_env complete_name ) env @@ -968,11 +1005,11 @@ module Analyser = | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum in let name = ct_decl.Parsetree.pci_name in - let complete_name = Name.concat current_module_name name in + let complete_name = Name.concat current_module_name name.txt in let sig_cltype_decl = - try Signature_search.search_class_type table name + try Signature_search.search_class_type table name.txt with Not_found -> - raise (Failure (Odoc_messages.class_type_not_found current_module_name name)) + raise (Failure (Odoc_messages.class_type_not_found current_module_name name.txt)) in let sig_class_type = sig_cltype_decl.Types.clty_type in let kind = analyse_class_type_kind @@ -990,7 +1027,7 @@ module Analyser = clt_type_parameters = sig_cltype_decl.clty_params ; clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ; clt_kind = kind ; - clt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; + clt_loc = { loc_impl = None ; loc_inter = Some ct_decl.Parsetree.pci_loc } ; } in let (maybe_more, info_after_opt) = @@ -1011,13 +1048,14 @@ module Analyser = (maybe_more, new_env, eles) (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) - and analyse_module_type_kind env current_module_name module_type sig_module_type = + and analyse_module_type_kind + ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> let name = match sig_module_type with - Types.Tmty_ident path -> Name.from_path path - | _ -> Name.from_longident longident + Types.Mty_ident path -> Name.from_path path + | _ -> Name.from_longident longident.txt (* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *) in Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ; @@ -1025,25 +1063,26 @@ module Analyser = | Parsetree.Pmty_signature ast -> ( + let ast = filter_out_erased_items_from_signature erased ast in (* we must have a signature in the module type *) match sig_module_type with - Types.Tmty_signature signat -> + Types.Mty_signature signat -> let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in Module_type_struct elements | _ -> - raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat") + raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat") ) - | Parsetree.Pmty_functor (_,pmodule_type2, module_type2) -> + | Parsetree.Pmty_functor (_, pmodule_type2, module_type2) -> ( let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let mp_type_code = get_string_of_file loc_start loc_end in print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); match sig_module_type with - Types.Tmty_functor (ident, param_module_type, body_module_type) -> + Types.Mty_functor (ident, param_module_type, body_module_type) -> let mp_kind = analyse_module_type_kind env current_module_name pmodule_type2 param_module_type in @@ -1055,25 +1094,27 @@ module Analyser = mp_kind = mp_kind ; } in - let k = analyse_module_type_kind env - current_module_name - module_type2 - body_module_type - in + let k = analyse_module_type_kind ~erased env + current_module_name + module_type2 + body_module_type + in Module_type_functor (param, k) | _ -> (* if we're here something's wrong *) - raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _") + raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _") ) - | Parsetree.Pmty_with (module_type2, _) -> + | Parsetree.Pmty_with (module_type2, constraints) -> (* of module_type * (Longident.t * with_constraint) list *) ( let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in - let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in + let erased = erased_names_of_constraints constraints erased in + let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in + Module_type_with (k, s) ) @@ -1084,7 +1125,8 @@ module Analyser = Module_type_typeof s (** analyse of a Parsetree.module_type and a Types.module_type.*) - and analyse_module_kind env current_module_name module_type sig_module_type = + and analyse_module_kind + ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in @@ -1092,8 +1134,9 @@ module Analyser = | Parsetree.Pmty_signature signature -> ( + let signature = filter_out_erased_items_from_signature erased signature in match sig_module_type with - Types.Tmty_signature signat -> + Types.Mty_signature signat -> Module_struct (analyse_parsetree env @@ -1105,12 +1148,12 @@ module Analyser = ) | _ -> (* if we're here something's wrong *) - raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat") + raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat") ) - | Parsetree.Pmty_functor (_,pmodule_type2,module_type2) (* of string * module_type * module_type *) -> + | Parsetree.Pmty_functor (_, pmodule_type2,module_type2) (* of string * module_type * module_type *) -> ( match sig_module_type with - Types.Tmty_functor (ident, param_module_type, body_module_type) -> + Types.Mty_functor (ident, param_module_type, body_module_type) -> let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let mp_type_code = get_string_of_file loc_start loc_end in @@ -1126,7 +1169,7 @@ module Analyser = mp_kind = mp_kind ; } in - let k = analyse_module_kind env + let k = analyse_module_kind ~erased env current_module_name module_type2 body_module_type @@ -1135,15 +1178,16 @@ module Analyser = | _ -> (* if we're here something's wrong *) - raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _") + raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _") ) - | Parsetree.Pmty_with (module_type2, _) -> + | Parsetree.Pmty_with (module_type2, constraints) -> (*of module_type * (Longident.t * with_constraint) list*) ( let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in - let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in + let erased = erased_names_of_constraints constraints erased in + let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in Module_with (k, s) ) | Parsetree.Pmty_typeof module_expr -> @@ -1157,8 +1201,8 @@ module Analyser = and analyse_class_kind env current_class_name last_pos parse_class_type sig_class_type = match parse_class_type.Parsetree.pcty_desc, sig_class_type with (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), - Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> - print_DEBUG "Tcty_constr _"; + Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> + print_DEBUG "Cty_constr _"; let path_name = Name.from_path p in let name = Odoc_env.full_class_or_class_type_name env path_name in let k = @@ -1171,7 +1215,7 @@ module Analyser = in ([], k) - | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> + | (Parsetree.Pcty_signature { Parsetree.pcsig_fields = class_type_field_list }, Types.Cty_signature class_signature) -> (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos @@ -1181,8 +1225,8 @@ module Analyser = in ([], 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 *) + | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Cty_fun (label, type_expr, class_type)) -> + (* 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 ( @@ -1198,7 +1242,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") ) | _ -> @@ -1208,8 +1252,8 @@ module Analyser = and analyse_class_type_kind env current_class_name last_pos parse_class_type sig_class_type = match parse_class_type.Parsetree.pcty_desc, sig_class_type with (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), - Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> - print_DEBUG "Tcty_constr _"; + Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> + print_DEBUG "Cty_constr _"; let k = Class_type { @@ -1220,7 +1264,9 @@ module Analyser = in k - | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> + | (Parsetree.Pcty_signature { + Parsetree.pcsig_fields = class_type_field_list; + }, Types.Cty_signature class_signature) -> (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos @@ -1230,11 +1276,11 @@ module Analyser = in Class_signature (inher_l, ele) - | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> - raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Tcty_fun (...)") + | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Cty_fun (label, type_expr, class_type)) -> + raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Cty_fun (...)") (* | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *), - Types.Tcty_signature class_signature) -> + Types.Cty_signature class_signature) -> (* A VOIR : c'est pour le cas des contraintes de classes : class type cons = object method m : int @@ -1293,12 +1339,12 @@ module Analyser = in { m_name = mod_name ; - m_type = Types.Tmty_signature signat ; + m_type = Types.Mty_signature signat ; m_info = info_opt ; m_is_interface = true ; m_file = !file_name ; m_kind = Module_struct elements ; - m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ; + m_loc = { loc_impl = None ; loc_inter = Some (Location.in_file !file_name) } ; m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli index 1ed0dbf150..11d852e757 100644 --- a/ocamldoc/odoc_sig.mli +++ b/ocamldoc/odoc_sig.mli @@ -46,7 +46,7 @@ module Signature_search : (** This function returns the Types.cltype_declaration for the class type whose name is given, in the given table. @raise Not_found if error.*) - val search_class_type : tab -> string -> Types.cltype_declaration + val search_class_type : tab -> string -> Types.class_type_declaration (** This function returns the Types.module_type for the module whose name is given, in the given table. @@ -155,8 +155,8 @@ module Analyser : Odoc_types.info option (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) - val analyse_module_type_kind : - Odoc_env.env -> Odoc_name.t -> + val analyse_module_type_kind : + ?erased:Odoc_name.Set.t -> Odoc_env.env -> Odoc_name.t -> Parsetree.module_type -> Types.module_type -> Odoc_module.module_type_kind diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 0c8873c195..ee97523dd4 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -128,7 +128,7 @@ let string_of_class_type_param_list l = let string_of_class_params c = let b = Buffer.create 256 in let rec iter = function - Types.Tcty_fun (label, t, ctype) -> + Types.Cty_fun (label, t, ctype) -> let parent = is_arrow_type t in Printf.bprintf b "%s%s%s%s -> " ( @@ -146,8 +146,8 @@ let string_of_class_params c = ) (if parent then ")" else ""); iter ctype - | Types.Tcty_signature _ - | Types.Tcty_constr _ -> () + | Types.Cty_signature _ + | Types.Cty_constr _ -> () in iter c.Odoc_class.cl_type; Buffer.contents b diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml index 7b455f45bf..a903b1c151 100644 --- a/ocamldoc/odoc_test.ml +++ b/ocamldoc/odoc_test.ml @@ -22,12 +22,13 @@ type test_kind = let p = Format.fprintf -module Generator = +module Generator (G : Odoc_gen.Base) = struct -class string_gen = + class string_gen = object(self) inherit Odoc_info.Scan.scanner + val mutable test_kinds = [] val mutable fmt = Format.str_formatter @@ -111,8 +112,12 @@ class string_gen = class generator = let g = new string_gen in object - method generate = g#generate + inherit G.generator as base + + method generate l = + base#generate l; + g#generate l end end;; -let _ = Odoc_args.set_generator (Odoc_gen.Other (module Generator : Odoc_gen.Base)) +let _ = Odoc_args.extend_base_generator (module Generator : Odoc_gen.Base_functor);; diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml index cfb9ec8f9a..a33c053b18 100644 --- a/ocamldoc/odoc_text.ml +++ b/ocamldoc/odoc_text.ml @@ -174,6 +174,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 13b5ccbcaa..082211f555 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_superscript = "{^"blank_nl | "{^" @@ -793,7 +795,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 ; diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly index cc6350f7cb..811aa239be 100644 --- a/ocamldoc/odoc_text_parser.mly +++ b/ocamldoc/odoc_text_parser.mly @@ -61,6 +61,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 @@ -79,8 +81,9 @@ let print_DEBUG s = print_string s; print_newline () %token <string> Char /* Start Symbols */ -%start main +%start main located_element_list %type <Odoc_types.text> main +%type <(int * int * Odoc_types.text_element) list> located_element_list %% main: @@ -97,6 +100,16 @@ text_element_list: | text_element text_element_list { $1 :: $2 } ; +located_element_list: + located_element { [ $1 ] } +| located_element located_element_list { $1 :: $2 } +; + +located_element: + text_element { Parsing.symbol_start (), Parsing.symbol_end (), $1} +; + + ele_ref_kind: ELE_REF { None } | VAL_REF { Some RK_value } @@ -109,6 +122,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_types.ml b/ocamldoc/odoc_types.ml index be8e4a2894..bbb6a2e386 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 @@ -90,8 +92,8 @@ let dummy_info = { } type location = { - loc_impl : (string * int) option ; - loc_inter : (string * int) option ; + loc_impl : Location.t option ; + loc_inter : Location.t option ; } let dummy_loc = { loc_impl = None ; loc_inter = None } diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli index c14c3411af..0913842591 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. *) @@ -93,8 +95,8 @@ val dummy_info : info (** Location of elements in implementation and interface files. *) type location = { - loc_impl : (string * int) option ; (** implementation file name and position *) - loc_inter : (string * int) option ; (** interface file name and position *) + loc_impl : Location.t option ; (** implementation location *) + loc_inter : Location.t option ; (** interface location *) } (** A dummy location. *) diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h index 71d43b9a4f..f310307f2a 100644 --- a/otherlibs/bigarray/bigarray.h +++ b/otherlibs/bigarray/bigarray.h @@ -73,8 +73,8 @@ 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 / gcc's flexible array types if possible */ -#if (__STDC_VERSION__ >= 199901L) || defined(__GNUC__) + /* 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 */ diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 5e9192022e..b4d18d79eb 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -27,9 +27,9 @@ 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} - and {!Pervasives.input_value}, as well as the functions from the - {!Marshal} module). + - and structured input-output (the functions from the + {!Marshal} module, as well as {!Pervasives.output_value} + and {!Pervasives.input_value}). *) (** {6 Element kinds} *) diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index 54a1939b80..5b8259ad0c 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -155,8 +155,8 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) if (data == NULL && size != 0) raise_out_of_memory(); flags |= BIGARRAY_MANAGED; } - /* PR#5516: use C99's / gcc's flexible array types if possible */ -#if (__STDC_VERSION__ >= 199901L) || defined(__GNUC__) + /* 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); diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index bf3fe6bd14..31eeabba88 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -33,7 +33,7 @@ COMPILEROBJS=\ ../../typing/ident.cmo ../../typing/path.cmo \ ../../typing/primitive.cmo ../../typing/types.cmo \ ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \ - ../../typing/datarepr.cmo ../../typing/env.cmo \ + ../../typing/datarepr.cmo ../../typing/cmi_format.cmo ../../typing/env.cmo \ ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \ ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \ ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \ diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 74d87b7802..ee136fe2c7 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -126,13 +126,13 @@ let digest_interface unit loadpath = close_in ic; raise(Error(Corrupted_interface filename)) end; - ignore (input_value ic); + let cmi = Cmi_format.input_cmi ic in + close_in ic; let crc = - match input_value ic with + match cmi.Cmi_format.cmi_crcs with (_, crc) :: _ -> crc | _ -> raise(Error(Corrupted_interface filename)) in - close_in ic; crc with End_of_file | Failure _ -> close_in ic; @@ -158,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; @@ -187,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 -> @@ -198,6 +206,8 @@ 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 = try Misc.input_bytes ic (String.length Config.cmo_magic_number) @@ -206,7 +216,8 @@ let loadfile file_name = 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 *) @@ -218,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/dynlinkaux.mlpack b/otherlibs/dynlink/dynlinkaux.mlpack index 783e624af9..67b9538e83 100644 --- a/otherlibs/dynlink/dynlinkaux.mlpack +++ b/otherlibs/dynlink/dynlinkaux.mlpack @@ -1,5 +1,5 @@ Misc Config Clflags Tbl Consistbl -Terminfo Warnings Asttypes Linenum Location Longident +Terminfo Warnings Asttypes Location Longident Ident Path Primitive Types Btype Subst Predef -Datarepr Env Lambda Instruct Cmo_format Opcodes +Datarepr Cmi_format Env Lambda Instruct Cmo_format Opcodes Runtimedef Bytesections Dll Meta Symtable diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli index 60c0f66dba..408aea9b48 100644 --- a/otherlibs/num/ratio.mli +++ b/otherlibs/num/ratio.mli @@ -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/systhreads/.depend b/otherlibs/systhreads/.depend index 54abcf1fca..b1a235c6ec 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -5,7 +5,7 @@ join.o: join.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/roots.h ../../byterun/memory.h \ ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/misc.h + ../../byterun/fail.h ../../byterun/misc.h st_stubs.o: st_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index eeb2329dd9..7376615ed9 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -56,7 +56,7 @@ all: libthreads.a threads.cma allopt: libthreadsnat.a threads.cmxa libthreads.a: $(BYTECODE_C_OBJS) - $(MKLIB) -o threads $(BYTECODE_C_OBJS) + $(MKLIB) -o threads $(BYTECODE_C_OBJS) -lpthread st_stubs_b.o: st_stubs.c st_posix.h $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index ba10205eb1..9b2493a16e 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -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 OCaml 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 diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 2a99967abe..c959f99288 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -5,7 +5,7 @@ join.o: join.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/roots.h ../../byterun/memory.h \ ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/misc.h + ../../byterun/fail.h ../../byterun/misc.h scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index f8b7bab91c..7e8b7d3d3d 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -38,22 +38,19 @@ CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo $(JOIN_OBJ LIB=../../stdlib LIB_OBJS=pervasives.cmo \ - $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ - $(LIB)/sys.cmo $(LIB)/hashtbl.cmo $(LIB)/sort.cmo \ - marshal.cmo $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \ - $(LIB)/nativeint.cmo \ - $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ - $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ - $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo \ - $(LIB)/stream.cmo $(LIB)/buffer.cmo \ - $(LIB)/printf.cmo $(LIB)/format.cmo \ - $(LIB)/scanf.cmo $(LIB)/arg.cmo \ - $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \ - $(LIB)/camlinternalOO.cmo $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo \ - $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \ - $(LIB)/filename.cmo $(LIB)/complex.cmo \ - $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \ - $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo + $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ + $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo $(LIB)/obj.cmo \ + $(LIB)/int32.cmo $(LIB)/int64.cmo $(LIB)/nativeint.cmo \ + $(LIB)/lexing.cmo $(LIB)/parsing.cmo $(LIB)/set.cmo $(LIB)/map.cmo \ + $(LIB)/stack.cmo $(LIB)/queue.cmo $(LIB)/camlinternalLazy.cmo \ + $(LIB)/lazy.cmo $(LIB)/stream.cmo $(LIB)/buffer.cmo \ + $(LIB)/printf.cmo $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo \ + $(LIB)/digest.cmo $(LIB)/random.cmo $(LIB)/hashtbl.cmo \ + $(LIB)/format.cmo $(LIB)/scanf.cmo $(LIB)/camlinternalOO.cmo \ + $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \ + $(LIB)/callback.cmo $(LIB)/weak.cmo $(LIB)/filename.cmo \ + $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \ + $(LIB)/stringLabels.cmo $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo UNIXLIB=../unix diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli index 11842e5ad0..eb37f01249 100644 --- a/otherlibs/threads/event.mli +++ b/otherlibs/threads/event.mli @@ -59,8 +59,8 @@ val wrap_abort : 'a event -> (unit -> unit) -> 'a event val guard : (unit -> 'a event) -> 'a event (** [guard fn] returns the event that, when synchronized, computes - [fn()] and behaves as the resulting event. This allows to - compute events with side-effects at the time of the synchronization + [fn()] and behaves as the resulting event. This allows events with + side-effects to be computed at the time of the synchronization operation. *) val sync : 'a event -> 'a diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h index a90bb2dcf2..c631ef1503 100644 --- a/otherlibs/unix/unixsupport.h +++ b/otherlibs/unix/unixsupport.h @@ -23,6 +23,6 @@ extern value unix_error_of_code (int errcode); extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; extern void uerror (char * cmdname, value arg) Noreturn; -#define UNIX_BUFFER_SIZE 16384 +#define UNIX_BUFFER_SIZE 65536 #define DIR_Val(v) *((DIR **) &Field(v, 0)) diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index d23a87fb7b..ecdfcc5fd4 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -38,3 +38,8 @@ type override_flag = Override | Fresh type closed_flag = Closed | Open type label = string + +type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; +} diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 175eedc900..d3dc035fe2 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -14,15 +14,16 @@ (* The lexical analyzer *) +val init : unit -> unit val token: Lexing.lexbuf -> Parser.token val skip_sharp_bang: Lexing.lexbuf -> unit type error = | Illegal_character of char | Illegal_escape of string - | Unterminated_comment + | Unterminated_comment of Location.t | Unterminated_string - | Unterminated_string_in_comment + | Unterminated_string_in_comment of Location.t | Keyword_as_label of string | Literal_overflow of string ;; @@ -34,3 +35,9 @@ open Format val report_error: formatter -> error -> unit val in_comment : unit -> bool;; +val in_string : unit -> bool;; + + +val print_warnings : bool ref +val comments : unit -> (string * Location.t) list +val token_with_comments : Lexing.lexbuf -> Parser.token diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 63d1c42fd3..4c90e6dc18 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -22,9 +22,9 @@ open Parser type error = | Illegal_character of char | Illegal_escape of string - | Unterminated_comment + | Unterminated_comment of Location.t | Unterminated_string - | Unterminated_string_in_comment + | Unterminated_string_in_comment of Location.t | Keyword_as_label of string | Literal_overflow of string ;; @@ -123,6 +123,12 @@ let store_string_char c = String.unsafe_set (!string_buff) (!string_index) c; incr string_index +let store_lexeme lexbuf = + let s = Lexing.lexeme lexbuf in + for i = 0 to String.length s - 1 do + store_string_char s.[i]; + done + let get_stored_string () = let s = String.sub (!string_buff) 0 (!string_index) in string_buff := initial_string_buffer; @@ -132,6 +138,9 @@ let get_stored_string () = let string_start_loc = ref Location.none;; let comment_start_loc = ref [];; let in_comment () = !comment_start_loc <> [];; +let is_in_string = ref false +let in_string () = !is_in_string +let print_warnings = ref true (* To translate escape sequences *) @@ -214,11 +223,11 @@ let report_error ppf = function fprintf ppf "Illegal character (%s)" (Char.escaped c) | Illegal_escape s -> fprintf ppf "Illegal backslash escape in string or character (%s)" s - | Unterminated_comment -> + | Unterminated_comment _ -> fprintf ppf "Comment not terminated" | Unterminated_string -> fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment -> + | Unterminated_string_in_comment _ -> fprintf ppf "This comment contains an unterminated string literal" | Keyword_as_label kwd -> fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd @@ -309,9 +318,11 @@ rule token = parse raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) } | "\"" { reset_string_buffer(); + is_in_string := true; let string_start = lexbuf.lex_start_p in string_start_loc := Location.curr lexbuf; string lexbuf; + is_in_string := false; lexbuf.lex_start_p <- string_start; STRING (get_stored_string()) } | "'" newline "'" @@ -331,15 +342,24 @@ rule token = parse raise (Error(Illegal_escape esc, Location.curr lexbuf)) } | "(*" - { comment_start_loc := [Location.curr lexbuf]; - comment lexbuf; - token lexbuf } + { let start_loc = Location.curr lexbuf in + comment_start_loc := [start_loc]; + reset_string_buffer (); + let end_loc = comment lexbuf in + let s = get_stored_string () in + reset_string_buffer (); + COMMENT (s, { start_loc with Location.loc_end = end_loc.Location.loc_end }) + } | "(*)" - { let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Comment_start; - comment_start_loc := [Location.curr lexbuf]; - comment lexbuf; - token lexbuf + { let loc = Location.curr lexbuf in + if !print_warnings then + Location.prerr_warning loc Warnings.Comment_start; + comment_start_loc := [loc]; + reset_string_buffer (); + let end_loc = comment lexbuf in + let s = get_stored_string () in + reset_string_buffer (); + COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end }) } | "*)" { let loc = Location.curr lexbuf in @@ -421,53 +441,64 @@ rule token = parse and comment = parse "(*" { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; + store_lexeme lexbuf; comment lexbuf; } | "*)" { match !comment_start_loc with | [] -> assert false - | [_] -> comment_start_loc := []; + | [_] -> comment_start_loc := []; Location.curr lexbuf | _ :: l -> comment_start_loc := l; - comment lexbuf; + store_lexeme lexbuf; + comment lexbuf; } | "\"" - { reset_string_buffer(); + { string_start_loc := Location.curr lexbuf; + store_string_char '"'; + is_in_string := true; begin try string lexbuf with Error (Unterminated_string, _) -> match !comment_start_loc with | [] -> assert false - | loc :: _ -> comment_start_loc := []; - raise (Error (Unterminated_string_in_comment, loc)) + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + raise (Error (Unterminated_string_in_comment start, loc)) end; - reset_string_buffer (); + is_in_string := false; + store_string_char '"'; comment lexbuf } | "''" - { comment lexbuf } + { store_lexeme lexbuf; comment lexbuf } | "'" newline "'" { update_loc lexbuf None 1 false 1; + store_lexeme lexbuf; comment lexbuf } | "'" [^ '\\' '\'' '\010' '\013' ] "'" - { comment lexbuf } + { store_lexeme lexbuf; comment lexbuf } | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" - { comment lexbuf } + { store_lexeme lexbuf; comment lexbuf } | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { comment lexbuf } + { store_lexeme lexbuf; comment lexbuf } | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" - { comment lexbuf } + { store_lexeme lexbuf; comment lexbuf } | eof { match !comment_start_loc with | [] -> assert false - | loc :: _ -> comment_start_loc := []; - raise (Error (Unterminated_comment, loc)) + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + raise (Error (Unterminated_comment start, loc)) } | newline { update_loc lexbuf None 1 false 0; + store_lexeme lexbuf; comment lexbuf } | _ - { comment lexbuf } + { store_lexeme lexbuf; comment lexbuf } and string = parse '"' @@ -504,14 +535,12 @@ and string = parse { if not (in_comment ()) then Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; update_loc lexbuf None 1 false 0; - let s = Lexing.lexeme lexbuf in - for i = 0 to String.length s - 1 do - store_string_char s.[i]; - done; + store_lexeme lexbuf; string lexbuf } | eof - { raise (Error (Unterminated_string, !string_start_loc)) } + { is_in_string := false; + raise (Error (Unterminated_string, !string_start_loc)) } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } @@ -522,3 +551,21 @@ and skip_sharp_bang = parse | "#!" [^ '\n']* '\n' { update_loc lexbuf None 1 false 0 } | "" { () } + +{ + let token_with_comments = token + + let last_comments = ref [] + let rec token lexbuf = + match token_with_comments lexbuf with + COMMENT (s, comment_loc) -> + last_comments := (s, comment_loc) :: !last_comments; + token lexbuf + | tok -> tok + let comments () = List.rev !last_comments + let init () = + is_in_string := false; + last_comments := []; + comment_start_loc := [] + +} diff --git a/parsing/location.ml b/parsing/location.ml index 02b135fae0..973ab4bb85 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -223,8 +223,8 @@ let print_filename ppf 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 = @@ -236,7 +236,7 @@ let print_loc ppf loc = let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in 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%a%s%i" msg_file print_filename file msg_line line; @@ -248,7 +248,8 @@ let print_loc ppf loc = let print ppf loc = if loc.loc_start.pos_fname = "//toplevel//" && highlight_locations ppf loc none then () - else fprintf ppf "%a%s@.%s" print_loc loc msg_colon msg_head + else fprintf ppf "%a%s@." print_loc loc msg_colon +;; let print_error ppf loc = print ppf loc; @@ -275,3 +276,11 @@ let prerr_warning loc w = print_warning loc err_formatter w;; let echo_eof () = print_newline (); incr num_loc_lines + +type 'a loc = { + txt : 'a; + loc : t; +} + +let mkloc txt loc = { txt ; loc } +let mknoloc txt = mkloc txt none diff --git a/parsing/location.mli b/parsing/location.mli index 1f12366fd0..23c5c979b3 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -41,6 +41,9 @@ val curr : Lexing.lexbuf -> t val symbol_rloc: unit -> t val symbol_gloc: unit -> t + +(** [rhs_loc n] returns the location of the symbol at position [n], starting + at 1, in the current parser rule. *) val rhs_loc: int -> t val input_name: string ref @@ -57,12 +60,21 @@ val reset: unit -> unit val highlight_locations: formatter -> t -> t -> bool +type 'a loc = { + txt : 'a; + loc : t; +} + +val mknoloc : 'a -> 'a loc +val mkloc : 'a -> t -> 'a loc + val print: formatter -> t -> unit val print_filename: formatter -> string -> unit val show_filename: string -> string (** In -absname mode, return the absolute path for this filename. Otherwise, returns the filename unchanged. *) - + val absname: bool ref + diff --git a/parsing/parse.ml b/parsing/parse.ml index cf862af3f1..1fc61a6f4a 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -24,9 +24,9 @@ let rec skip_phrase lexbuf = Parser.SEMISEMI | Parser.EOF -> () | _ -> skip_phrase lexbuf with - | Lexer.Error (Lexer.Unterminated_comment, _) -> () + | Lexer.Error (Lexer.Unterminated_comment _, _) -> () | Lexer.Error (Lexer.Unterminated_string, _) -> () - | Lexer.Error (Lexer.Unterminated_string_in_comment, _) -> () + | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) -> () | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf ;; @@ -38,13 +38,14 @@ let maybe_skip_phrase lexbuf = let wrap parsing_fun lexbuf = try + Lexer.init (); let ast = parsing_fun Lexer.token lexbuf in Parsing.clear_parser(); ast with - | Lexer.Error(Lexer.Unterminated_comment, _) as err -> raise err + | Lexer.Error(Lexer.Unterminated_comment _, _) as err -> raise err | Lexer.Error(Lexer.Unterminated_string, _) as err -> raise err - | Lexer.Error(Lexer.Unterminated_string_in_comment, _) 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 = "//toplevel//" then skip_phrase lexbuf; raise err diff --git a/parsing/parser.mly b/parsing/parser.mly index b8bf43131b..2c7b80a8ee 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -40,19 +40,28 @@ let mkclass d = { pcl_desc = d; pcl_loc = symbol_rloc() } let mkcty d = { pcty_desc = d; pcty_loc = symbol_rloc() } +let mkctf d = + { pctf_desc = d; pctf_loc = symbol_rloc () } +let mkcf d = + { pcf_desc = d; pcf_loc = symbol_rloc () } +let mkrhs rhs pos = mkloc rhs (rhs_loc pos) +let mkoption d = + { ptyp_desc = Ptyp_constr(mknoloc (Ldot (Lident "*predef*", "option")), [d]); + ptyp_loc = d.ptyp_loc} let reloc_pat x = { x with ppat_loc = symbol_rloc () };; 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 loc = rhs_loc pos in + { pexp_desc = Pexp_ident(mkloc (Lident name) loc); pexp_loc = loc } let mkpatvar name pos = - { ppat_desc = Ppat_var name; ppat_loc = rhs_loc pos } + { ppat_desc = Ppat_var (mkrhs name pos); 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. @@ -73,9 +82,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); - pexp_loc = _ } -> - mkexp (Pexp_assertfalse) + | {pexp_desc = Pexp_construct ({ txt = Lident "false" }, None , false); + pexp_loc = _ } -> + mkexp (Pexp_assertfalse) | _ -> mkexp (Pexp_assert (e)) ;; @@ -113,9 +122,17 @@ let mkuplus name arg = | _ -> mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg])) +let mkexp_cons args loc = + {pexp_desc = Pexp_construct(mkloc (Lident "::") Location.none, + Some args, false); pexp_loc = loc} + +let mkpat_cons args loc = + {ppat_desc = Ppat_construct(mkloc (Lident "::") Location.none, + Some args, false); ppat_loc = loc} + let rec mktailexp = function [] -> - ghexp(Pexp_construct(Lident "[]", None, false)) + ghexp(Pexp_construct(mkloc (Lident "[]") Location.none, None, false)) | e1 :: el -> let exp_el = mktailexp el in let l = {loc_start = e1.pexp_loc.loc_start; @@ -123,11 +140,11 @@ let rec mktailexp = function loc_ghost = true} in let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in - {pexp_desc = Pexp_construct(Lident "::", Some arg, false); pexp_loc = l} + mkexp_cons arg l let rec mktailpat = function [] -> - ghpat(Ppat_construct(Lident "[]", None, false)) + ghpat(Ppat_construct(mkloc (Lident "[]") Location.none, None, false)) | p1 :: pl -> let pat_pl = mktailpat pl in let l = {loc_start = p1.ppat_loc.loc_start; @@ -135,13 +152,13 @@ let rec mktailpat = function loc_ghost = true} in let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in - {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l} + mkpat_cons arg l let ghstrexp e = { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} } let array_function str name = - Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)) + mknoloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))) let rec deep_mkrangepat c1 c2 = if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else @@ -161,7 +178,7 @@ let unclosed opening_name opening_num closing_name closing_num = rhs_loc closing_num, closing_name))) let bigarray_function str name = - Ldot(Ldot(Lident "Bigarray", str), name) + mkloc (Ldot(Ldot(Lident "Bigarray", str), name)) Location.none let bigarray_untuplify = function { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist @@ -206,76 +223,29 @@ let lapply p1 p2 = then Lapply(p1, p2) else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc()))) -let exp_of_label lbl = - mkexp (Pexp_ident(Lident(Longident.last lbl))) +let exp_of_label lbl pos = + mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos)) -let pat_of_label lbl = - mkpat (Ppat_var(Longident.last lbl)) +let pat_of_label lbl pos = + mkpat (Ppat_var (mkrhs (Longident.last lbl) pos)) -let variables_of_type = - let rec loop t = - match t.ptyp_desc with - | Ptyp_any -> [] - | Ptyp_var x -> [x] - | Ptyp_arrow (label,core_type,core_type') -> - loop core_type @ loop core_type' - | Ptyp_tuple lst -> List.concat (List.map loop lst) - | Ptyp_constr(longident, lst) -> - List.concat (List.map loop lst) - | Ptyp_object lst -> - List.concat (List.map loop_core_field lst) - | Ptyp_class (longident, lst, lbl_list) -> - List.concat (List.map loop lst) - | Ptyp_alias(core_type, str) -> - str :: loop core_type - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - List.concat (List.map loop_row_field row_field_list) - | Ptyp_poly(string_lst, core_type) -> - loop core_type - | Ptyp_package(longident,lst) -> - List.concat (List.map (fun (n,typ) -> (loop typ)) lst) - and loop_core_field t = - match t.pfield_desc with - | Pfield(n,typ) -> - loop typ - | Pfield_var -> - [] - and loop_row_field = - function - | Rtag(label,flag,lst) -> - List.concat (List.map loop lst) - | Rinherit t -> - loop t - in - loop +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 offlimits = variables_of_type t in - let freshly_created = ref [] in - let rec fresh ?(count=0) name = - let ret = if count = 0 then name else name ^ string_of_int count in - if List.mem ret offlimits then fresh ~count:(count+1) name else begin - freshly_created := ret :: !freshly_created; - ret - end - in - let sofar : (string,string) Hashtbl.t = Hashtbl.create 0 in let rec loop t = let desc = match t.ptyp_desc with | Ptyp_any -> Ptyp_any - | Ptyp_var x -> Ptyp_var x + | 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 -> - begin try - Ptyp_var (Hashtbl.find sofar s) - with - | Not_found -> - let name = fresh s in - Hashtbl.add sofar s name; - Ptyp_var name end + | Ptyp_constr( { txt = 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 -> @@ -283,10 +253,13 @@ let varify_constructors var_names t = | 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_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) @@ -308,7 +281,7 @@ let varify_constructors var_names t = | Rinherit t -> Rinherit (loop t) in - (!freshly_created,loop t) + loop t let wrap_type_annotation newtypes core_type body = let exp = mkexp(Pexp_constraint(body,Some core_type,None)) in @@ -316,8 +289,7 @@ let wrap_type_annotation newtypes core_type body = List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) newtypes exp in - let polyvars, core_type = varify_constructors newtypes core_type in - (exp, ghtyp(Ptyp_poly(polyvars,core_type))) + (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type))) %} @@ -434,6 +406,7 @@ let wrap_type_annotation newtypes core_type body = %token WHEN %token WHILE %token WITH +%token <string * Location.t> COMMENT %token DEF %token REPLY @@ -513,7 +486,8 @@ The precedences must be listed from low to high. %type <Parsetree.toplevel_phrase> toplevel_phrase %start use_file /* for the #use directive */ %type <Parsetree.toplevel_phrase list> use_file - +%start any_longident +%type <Longident.t> any_longident %% /* Entry points */ @@ -552,13 +526,13 @@ use_file_tail: module_expr: mod_longident - { mkmod(Pmod_ident $1) } + { mkmod(Pmod_ident (mkrhs $1 1)) } | STRUCT structure END { mkmod(Pmod_structure($2)) } | STRUCT structure error { unclosed "struct" 1 "end" 3 } | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr - { mkmod(Pmod_functor($3, $5, $8)) } + { mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) } | module_expr LPAREN module_expr RPAREN { mkmod(Pmod_apply($1, $3)) } | module_expr LPAREN module_expr error @@ -607,21 +581,22 @@ structure_item: [{ 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})) } + { mkstr(Pstr_primitive(mkrhs $2 2, {pval_type = $4; pval_prim = $6; + pval_loc = symbol_rloc ()})) } | TYPE type_declarations { mkstr(Pstr_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments - { mkstr(Pstr_exception($2, $3)) } + { mkstr(Pstr_exception(mkrhs $2 2, $3)) } | EXCEPTION UIDENT EQUAL constr_longident - { mkstr(Pstr_exn_rebind($2, $4)) } + { mkstr(Pstr_exn_rebind(mkrhs $2 2, mkloc $4 (rhs_loc 4))) } | MODULE UIDENT module_binding - { mkstr(Pstr_module($2, $3)) } + { mkstr(Pstr_module(mkrhs $2 2, $3)) } | MODULE REC module_rec_bindings { mkstr(Pstr_recmodule(List.rev $3)) } | MODULE TYPE ident EQUAL module_type - { mkstr(Pstr_modtype($3, $5)) } + { mkstr(Pstr_modtype(mkrhs $3 3, $5)) } | OPEN mod_longident - { mkstr(Pstr_open $2) } + { mkstr(Pstr_open (mkrhs $2 2)) } | CLASS class_declarations { mkstr(Pstr_class (List.rev $2)) } | CLASS TYPE class_type_declarations @@ -632,7 +607,7 @@ structure_item: | DEF joinautomaton_list_AND { mkstr(Pstr_def $2) } | DEF EXCEPTION constr_longident - { mkstr(Pstr_exn_global $3) } + { mkstr(Pstr_exn_global (mkloc $3 (rhs_loc 3))) } /*< JOCAML */ ; module_binding: @@ -641,28 +616,28 @@ module_binding: | COLON module_type EQUAL module_expr { mkmod(Pmod_constraint($4, $2)) } | LPAREN UIDENT COLON module_type RPAREN module_binding - { mkmod(Pmod_functor($2, $4, $6)) } + { mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) } ; module_rec_bindings: module_rec_binding { [$1] } | module_rec_bindings AND module_rec_binding { $3 :: $1 } ; module_rec_binding: - UIDENT COLON module_type EQUAL module_expr { ($1, $3, $5) } + UIDENT COLON module_type EQUAL module_expr { (mkrhs $1 1, $3, $5) } ; /* Module types */ module_type: mty_longident - { mkmty(Pmty_ident $1) } + { mkmty(Pmty_ident (mkrhs $1 1)) } | SIG signature END { mkmty(Pmty_signature(List.rev $2)) } | SIG signature error { unclosed "sig" 1 "end" 3 } | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type %prec below_WITH - { mkmty(Pmty_functor($3, $5, $8)) } + { mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) } | module_type WITH with_constraints { mkmty(Pmty_with($1, List.rev $3)) } | MODULE TYPE OF module_expr @@ -679,23 +654,25 @@ signature: ; signature_item: VAL val_ident COLON core_type - { mksig(Psig_value($2, {pval_type = $4; pval_prim = []})) } + { mksig(Psig_value(mkrhs $2 2, {pval_type = $4; pval_prim = []; + pval_loc = symbol_rloc()})) } | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration - { mksig(Psig_value($2, {pval_type = $4; pval_prim = $6})) } + { mksig(Psig_value(mkrhs $2 2, {pval_type = $4; pval_prim = $6; + pval_loc = symbol_rloc()})) } | TYPE type_declarations { mksig(Psig_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments - { mksig(Psig_exception($2, $3)) } + { mksig(Psig_exception(mkrhs $2 2, $3)) } | MODULE UIDENT module_declaration - { mksig(Psig_module($2, $3)) } + { mksig(Psig_module(mkrhs $2 2, $3)) } | MODULE REC module_rec_declarations { mksig(Psig_recmodule(List.rev $3)) } | MODULE TYPE ident - { mksig(Psig_modtype($3, Pmodtype_abstract)) } + { mksig(Psig_modtype(mkrhs $3 3, Pmodtype_abstract)) } | MODULE TYPE ident EQUAL module_type - { mksig(Psig_modtype($3, Pmodtype_manifest $5)) } + { mksig(Psig_modtype(mkrhs $3 3, Pmodtype_manifest $5)) } | OPEN mod_longident - { mksig(Psig_open $2) } + { mksig(Psig_open (mkrhs $2 2)) } | INCLUDE module_type { mksig(Psig_include $2) } | CLASS class_descriptions @@ -708,14 +685,14 @@ module_declaration: COLON module_type { $2 } | LPAREN UIDENT COLON module_type RPAREN module_declaration - { mkmty(Pmty_functor($2, $4, $6)) } + { mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) } ; module_rec_declarations: module_rec_declaration { [$1] } | module_rec_declarations AND module_rec_declaration { $3 :: $1 } ; module_rec_declaration: - UIDENT COLON module_type { ($1, $3) } + UIDENT COLON module_type { (mkrhs $1 1, $3) } ; /* Class expressions */ @@ -728,7 +705,7 @@ class_declaration: virtual_flag class_type_parameters LIDENT class_fun_binding { let params, variance = List.split (fst $2) in {pci_virt = $1; pci_params = params, snd $2; - pci_name = $3; pci_expr = $4; pci_variance = variance; + pci_name = mkrhs $3 3; pci_expr = $4; pci_variance = variance; pci_loc = symbol_rloc ()} } ; class_fun_binding: @@ -761,9 +738,9 @@ class_expr: ; class_simple_expr: LBRACKET core_type_comma_list RBRACKET class_longident - { mkclass(Pcl_constr($4, List.rev $2)) } + { mkclass(Pcl_constr(mkloc $4 (rhs_loc 4), List.rev $2)) } | class_longident - { mkclass(Pcl_constr($1, [])) } + { mkclass(Pcl_constr(mkrhs $1 1, [])) } | OBJECT class_structure END { mkclass(Pcl_structure($2)) } | OBJECT class_structure error @@ -779,7 +756,7 @@ class_simple_expr: ; class_structure: class_self_pattern class_fields - { $1, List.rev $2 } + { { pcstr_pat = $1; pcstr_fields = List.rev $2 } } ; class_self_pattern: LPAREN pattern RPAREN @@ -792,20 +769,24 @@ class_self_pattern: class_fields: /* empty */ { [] } - | class_fields INHERIT override_flag class_expr parent_binder - { Pcf_inher ($3, $4, $5) :: $1 } - | class_fields VAL virtual_value - { Pcf_valvirt $3 :: $1 } - | class_fields VAL value - { Pcf_val $3 :: $1 } - | class_fields virtual_method - { Pcf_virt $2 :: $1 } - | class_fields concrete_method - { Pcf_meth $2 :: $1 } - | class_fields CONSTRAINT constrain - { Pcf_cstr $3 :: $1 } - | class_fields INITIALIZER seq_expr - { Pcf_init $3 :: $1 } + | class_fields class_field + { $2 :: $1 } +; +class_field: + | INHERIT override_flag class_expr parent_binder + { mkcf (Pcf_inher ($2, $3, $4)) } + | VAL virtual_value + { mkcf (Pcf_valvirt $2) } + | VAL value + { mkcf (Pcf_val $2) } + | virtual_method + { mkcf (Pcf_virt $1) } + | concrete_method + { mkcf (Pcf_meth $1) } + | CONSTRAINT constrain_field + { mkcf (Pcf_constr $2) } + | INITIALIZER seq_expr + { mkcf (Pcf_init $2) } ; parent_binder: AS LIDENT @@ -816,34 +797,33 @@ parent_binder: virtual_value: override_flag MUTABLE VIRTUAL label COLON core_type { if $1 = Override then syntax_error (); - $4, Mutable, $6, symbol_rloc () } + mkloc $4 (rhs_loc 4), Mutable, $6 } | VIRTUAL mutable_flag label COLON core_type - { $3, $2, $5, symbol_rloc () } + { mkrhs $3 3, $2, $5 } ; value: override_flag mutable_flag label EQUAL seq_expr - { $3, $2, $1, $5, symbol_rloc () } + { mkrhs $3 3, $2, $1, $5 } | override_flag mutable_flag label type_constraint EQUAL seq_expr - { $3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))), - symbol_rloc () } + { mkrhs $3 3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))) }, ; virtual_method: METHOD override_flag PRIVATE VIRTUAL label COLON poly_type { if $2 = Override then syntax_error (); - $5, Private, $7, symbol_rloc () } + mkloc $5 (rhs_loc 5), Private, $7 } | METHOD override_flag VIRTUAL private_flag label COLON poly_type { if $2 = Override then syntax_error (); - $5, $4, $7, symbol_rloc () } + mkloc $5 (rhs_loc 5), $4, $7 } ; concrete_method : METHOD override_flag private_flag label strict_binding - { $4, $3, $2, ghexp(Pexp_poly ($5, None)), symbol_rloc () } + { mkloc $4 (rhs_loc 4), $3, $2, ghexp(Pexp_poly ($5, None)) } | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr - { $4, $3, $2, ghexp(Pexp_poly($8,Some $6)), symbol_rloc () } + { mkloc $4 (rhs_loc 4), $3, $2, ghexp(Pexp_poly($8,Some $6)) } | 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 () } + mkloc $4 (rhs_loc 4), $3, $2, ghexp(Pexp_poly(exp, Some poly)) } ; /* Class types */ @@ -852,17 +832,9 @@ class_type: class_signature { $1 } | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_fun("?" ^ $2 , - {ptyp_desc = - Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); - ptyp_loc = $4.ptyp_loc}, - $6)) } + { mkcty(Pcty_fun("?" ^ $2 , mkoption $4, $6)) } | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_fun("?" ^ $1 , - {ptyp_desc = - Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); - ptyp_loc = $2.ptyp_loc}, - $4)) } + { mkcty(Pcty_fun("?" ^ $1, mkoption $2, $4)) } | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun($1, $3, $5)) } | simple_core_type_or_tuple MINUSGREATER class_type @@ -870,9 +842,9 @@ class_type: ; class_signature: LBRACKET core_type_comma_list RBRACKET clty_longident - { mkcty(Pcty_constr ($4, List.rev $2)) } + { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) } | clty_longident - { mkcty(Pcty_constr ($1, [])) } + { mkcty(Pcty_constr (mkrhs $1 1, [])) } | OBJECT class_sig_body END { mkcty(Pcty_signature $2) } | OBJECT class_sig_body error @@ -880,7 +852,8 @@ class_signature: ; class_sig_body: class_self_type class_sig_fields - { $1, List.rev $2 } + { { pcsig_self = $1; pcsig_fields = List.rev $2; + pcsig_loc = symbol_rloc(); } } ; class_self_type: LPAREN core_type RPAREN @@ -890,32 +863,38 @@ class_self_type: ; class_sig_fields: /* empty */ { [] } - | class_sig_fields INHERIT class_signature { Pctf_inher $3 :: $1 } - | class_sig_fields VAL value_type { Pctf_val $3 :: $1 } - | class_sig_fields virtual_method_type { Pctf_virt $2 :: $1 } - | class_sig_fields method_type { Pctf_meth $2 :: $1 } - | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 } +| class_sig_fields class_sig_field { $2 :: $1 } +; +class_sig_field: + INHERIT class_signature { mkctf (Pctf_inher $2) } + | VAL value_type { mkctf (Pctf_val $2) } + | virtual_method_type { mkctf (Pctf_virt $1) } + | method_type { mkctf (Pctf_meth $1) } + | CONSTRAINT constrain_field { mkctf (Pctf_cstr $2) } ; value_type: VIRTUAL mutable_flag label COLON core_type - { $3, $2, Virtual, $5, symbol_rloc () } + { $3, $2, Virtual, $5 } | MUTABLE virtual_flag label COLON core_type - { $3, Mutable, $2, $5, symbol_rloc () } + { $3, Mutable, $2, $5 } | label COLON core_type - { $1, Immutable, Concrete, $3, symbol_rloc () } + { $1, Immutable, Concrete, $3 } ; method_type: METHOD private_flag label COLON poly_type - { $3, $2, $5, symbol_rloc () } + { $3, $2, $5 } ; virtual_method_type: METHOD PRIVATE VIRTUAL label COLON poly_type - { $4, Private, $6, symbol_rloc () } + { $4, Private, $6 } | METHOD VIRTUAL private_flag label COLON poly_type - { $4, $3, $6, symbol_rloc () } + { $4, $3, $6 } ; constrain: - core_type EQUAL core_type { $1, $3, symbol_rloc () } + core_type EQUAL core_type { $1, $3, symbol_rloc() } +; +constrain_field: + core_type EQUAL core_type { $1, $3 } ; class_descriptions: class_descriptions AND class_description { $3 :: $1 } @@ -925,7 +904,7 @@ class_description: virtual_flag class_type_parameters LIDENT COLON class_type { let params, variance = List.split (fst $2) in {pci_virt = $1; pci_params = params, snd $2; - pci_name = $3; pci_expr = $5; pci_variance = variance; + pci_name = mkrhs $3 3; pci_expr = $5; pci_variance = variance; pci_loc = symbol_rloc ()} } ; class_type_declarations: @@ -936,7 +915,7 @@ class_type_declaration: virtual_flag class_type_parameters LIDENT EQUAL class_signature { let params, variance = List.split (fst $2) in {pci_virt = $1; pci_params = params, snd $2; - pci_name = $3; pci_expr = $5; pci_variance = variance; + pci_name = mkrhs $3 3; pci_expr = $5; pci_variance = variance; pci_loc = symbol_rloc ()} } ; @@ -966,7 +945,7 @@ labeled_simple_pattern: { ("", None, $1) } ; pattern_var: - LIDENT { mkpat(Ppat_var $1) } + LIDENT { mkpat(Ppat_var (mkrhs $1 1)) } | UNDERSCORE { mkpat Ppat_any } ; opt_default: @@ -980,7 +959,7 @@ label_let_pattern: { let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) } ; label_var: - LIDENT { ($1, mkpat(Ppat_var $1)) } + LIDENT { ($1, mkpat(Ppat_var (mkrhs $1 1))) } ; let_pattern: pattern @@ -996,9 +975,9 @@ expr: | LET rec_flag let_bindings IN seq_expr { mkexp(Pexp_let($2, List.rev $3, $5)) } | LET MODULE UIDENT module_binding IN seq_expr - { mkexp(Pexp_letmodule($3, $4, $6)) } + { mkexp(Pexp_letmodule(mkrhs $3 3, $4, $6)) } | LET OPEN mod_longident IN seq_expr - { mkexp(Pexp_open($3, $5)) } + { mkexp(Pexp_open(mkrhs $3 3, $5)) } | FUNCTION opt_bar match_cases { mkexp(Pexp_function("", None, List.rev $3)) } | FUN labeled_simple_pattern fun_def @@ -1014,7 +993,7 @@ expr: | expr_comma_list %prec below_COMMA { mkexp(Pexp_tuple(List.rev $1)) } | constr_longident simple_expr %prec below_SHARP - { mkexp(Pexp_construct($1, Some $2, false)) } + { mkexp(Pexp_construct(mkrhs $1 1, Some $2, false)) } | name_tag simple_expr %prec below_SHARP { mkexp(Pexp_variant($1, Some $2)) } | IF seq_expr THEN expr ELSE expr @@ -1024,15 +1003,11 @@ expr: | WHILE seq_expr DO seq_expr DONE { mkexp(Pexp_while($2, $4)) } | FOR val_ident EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE - { mkexp(Pexp_for($2, $4, $6, $5, $8)) } + { mkexp(Pexp_for(mkrhs $2 2, $4, $6, $5, $8)) } | expr COLONCOLON expr - { mkexp(Pexp_construct(Lident "::", - Some(ghexp(Pexp_tuple[$1;$3])), - false)) } + { mkexp_cons (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) } | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN - { mkexp(Pexp_construct(Lident "::", - Some(ghexp(Pexp_tuple[$5;$7])), - false)) } + { mkexp_cons (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) } | expr INFIXOP0 expr { mkinfix $1 $2 $3 } | expr INFIXOP1 expr @@ -1072,7 +1047,7 @@ expr: | additive expr %prec prec_unary_plus { mkuplus $1 $2 } | simple_expr DOT label_longident LESSMINUS expr - { mkexp(Pexp_setfield($1, $3, $5)) } + { mkexp(Pexp_setfield($1, mkrhs $3 3, $5)) } | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), ["",$1; "",$4; "",$7])) } @@ -1082,7 +1057,7 @@ expr: | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr { bigarray_set $1 $4 $7 } | label LESSMINUS expr - { mkexp(Pexp_setinstvar($1, $3)) } + { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) } | ASSERT simple_expr %prec below_SHARP { mkassert $2 } | LAZY simple_expr %prec below_SHARP @@ -1095,7 +1070,10 @@ expr: | REPLY TO joinident { mkexp (Pexp_reply - (ghexp (Pexp_construct (Lident "()", None, false)), $3)) } + (ghexp + (Pexp_construct + (mkloc (Lident "()") (symbol_rloc ()), + None, false)), $3)) } | REPLY seq_expr TO joinident { mkexp(Pexp_reply($2,$4)) } | SPAWN expr { mkexp(Pexp_spawn $2) } | DEF joinautomaton_list_AND IN seq_expr { mkexp(Pexp_def($2,$4)) } @@ -1103,11 +1081,11 @@ expr: ; simple_expr: val_longident - { mkexp(Pexp_ident $1) } + { mkexp(Pexp_ident (mkrhs $1 1)) } | constant { mkexp(Pexp_constant $1) } | constr_longident %prec prec_constant_constructor - { mkexp(Pexp_construct($1, None, false)) } + { mkexp(Pexp_construct(mkrhs $1 1, None, false)) } | name_tag %prec prec_constant_constructor { mkexp(Pexp_variant($1, None)) } | LPAREN seq_expr RPAREN @@ -1117,15 +1095,15 @@ simple_expr: | BEGIN seq_expr END { reloc_exp $2 } | BEGIN END - { mkexp (Pexp_construct (Lident "()", None, false)) } + { mkexp (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()), None, false)) } | BEGIN seq_expr error { unclosed "begin" 1 "end" 3 } | LPAREN seq_expr type_constraint RPAREN { let (t, t') = $3 in mkexp(Pexp_constraint($2, t, t')) } | simple_expr DOT label_longident - { mkexp(Pexp_field($1, $3)) } + { mkexp(Pexp_field($1, mkrhs $3 3)) } | mod_longident DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_open($1, $4)) } + { mkexp(Pexp_open(mkrhs $1 1, $4)) } | mod_longident DOT LPAREN seq_expr error { unclosed "(" 3 ")" 5 } | simple_expr DOT LPAREN seq_expr RPAREN @@ -1161,7 +1139,7 @@ simple_expr: | BANG simple_expr { mkexp(Pexp_apply(mkoperator "!" 1, ["",$2])) } | NEW class_longident - { mkexp(Pexp_new($2)) } + { mkexp(Pexp_new(mkrhs $2 2)) } | LBRACELESS field_expr_list opt_semi GREATERRBRACE { mkexp(Pexp_override(List.rev $2)) } | LBRACELESS field_expr_list opt_semi error @@ -1201,7 +1179,7 @@ label_expr: { ("?" ^ $1, $2) } ; label_ident: - LIDENT { ($1, mkexp(Pexp_ident(Lident $1))) } + LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) } ; let_bindings: let_binding { [$1] } @@ -1257,24 +1235,25 @@ expr_comma_list: | expr COMMA expr { [$3; $1] } ; record_expr: - simple_expr WITH lbl_expr_list opt_semi { (Some $1, List.rev $3) } - | lbl_expr_list opt_semi { (None, List.rev $1) } + simple_expr WITH lbl_expr_list { (Some $1, $3) } + | lbl_expr_list { (None, $1) } ; lbl_expr_list: + lbl_expr { [$1] } + | lbl_expr SEMI lbl_expr_list { $1 :: $3 } + | lbl_expr SEMI { [$1] } +; +lbl_expr: label_longident EQUAL expr - { [$1,$3] } + { (mkrhs $1 1,$3) } | label_longident - { [$1, exp_of_label $1] } - | lbl_expr_list SEMI label_longident EQUAL expr - { ($3, $5) :: $1 } - | lbl_expr_list SEMI label_longident - { ($3, exp_of_label $3) :: $1 } + { (mkrhs $1 1, exp_of_label $1 1) } ; field_expr_list: label EQUAL expr - { [$1,$3] } + { [mkrhs $1 1,$3] } | field_expr_list SEMI label EQUAL expr - { ($3, $5) :: $1 } + { (mkrhs $3 3, $5) :: $1 } ; expr_semi_list: expr { [$1] } @@ -1294,19 +1273,17 @@ pattern: simple_pattern { $1 } | pattern AS val_ident - { mkpat(Ppat_alias($1, $3)) } + { mkpat(Ppat_alias($1, mkrhs $3 3)) } | pattern_comma_list %prec below_COMMA { mkpat(Ppat_tuple(List.rev $1)) } | constr_longident pattern %prec prec_constr_appl - { mkpat(Ppat_construct($1, Some $2, false)) } + { mkpat(Ppat_construct(mkrhs $1 1, Some $2, false)) } | name_tag pattern %prec prec_constr_appl { mkpat(Ppat_variant($1, Some $2)) } | pattern COLONCOLON pattern - { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$1;$3])), - false)) } + { mkpat_cons (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }, | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN - { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$5;$7])), - false)) } + { mkpat_cons (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) } | pattern BAR pattern { mkpat(Ppat_or($1, $3)) } | LAZY simple_pattern @@ -1314,7 +1291,7 @@ pattern: ; simple_pattern: val_ident %prec below_EQUAL - { mkpat(Ppat_var $1) } + { mkpat(Ppat_var (mkrhs $1 1)) } | UNDERSCORE { mkpat(Ppat_any) } | signed_constant @@ -1322,14 +1299,14 @@ simple_pattern: | CHAR DOTDOT CHAR { mkrangepat $1 $3 } | constr_longident - { mkpat(Ppat_construct($1, None, false)) } + { mkpat(Ppat_construct(mkrhs $1 1, None, false)) } | name_tag { mkpat(Ppat_variant($1, None)) } | SHARP type_longident - { mkpat(Ppat_type $2) } - | LBRACE lbl_pattern_list record_pattern_end RBRACE - { mkpat(Ppat_record(List.rev $2, $3)) } - | LBRACE lbl_pattern_list opt_semi error + { mkpat(Ppat_type (mkrhs $2 2)) } + | LBRACE lbl_pattern_list RBRACE + { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) } + | LBRACE lbl_pattern_list error { unclosed "{" 1 "}" 4 } | LBRACKET pattern_semi_list opt_semi RBRACKET { reloc_pat (mktailpat (List.rev $2)) } @@ -1350,9 +1327,9 @@ simple_pattern: | LPAREN pattern COLON core_type error { unclosed "(" 1 ")" 5 } | LPAREN MODULE UIDENT RPAREN - { mkpat(Ppat_unpack $3) } + { mkpat(Ppat_unpack (mkrhs $3 3)) } | LPAREN MODULE UIDENT COLON package_type RPAREN - { mkpat(Ppat_constraint(mkpat(Ppat_unpack $3),ghtyp(Ptyp_package $5))) } + { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),ghtyp(Ptyp_package $5))) } | LPAREN MODULE UIDENT COLON package_type error { unclosed "(" 1 ")" 6 } ; @@ -1366,14 +1343,16 @@ pattern_semi_list: | pattern_semi_list SEMI pattern { $3 :: $1 } ; lbl_pattern_list: - label_longident EQUAL pattern { [($1, $3)] } - | label_longident { [($1, pat_of_label $1)] } - | lbl_pattern_list SEMI label_longident EQUAL pattern { ($3, $5) :: $1 } - | lbl_pattern_list SEMI label_longident { ($3, pat_of_label $3) :: $1 } -; -record_pattern_end: - opt_semi { Closed } - | SEMI UNDERSCORE opt_semi { Open } + lbl_pattern { [$1], Closed } + | lbl_pattern SEMI { [$1], Closed } + | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open } + | lbl_pattern SEMI lbl_pattern_list { let (fields, closed) = $3 in $1 :: fields, closed } +; +lbl_pattern: + label_longident EQUAL pattern + { (mkrhs $1 1,$3) } + | label_longident + { (mkrhs $1 1, pat_of_label $1 1) } ; /* Primitive declarations */ @@ -1394,7 +1373,7 @@ type_declaration: 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; + (mkrhs $2 2, {ptype_params = params; ptype_cstrs = List.rev $4; ptype_kind = kind; ptype_private = private_flag; @@ -1432,7 +1411,7 @@ optional_type_parameters: | LPAREN optional_type_parameter_list RPAREN { List.rev $2 } ; optional_type_parameter: - type_variance QUOTE ident { Some $3, $1 } + type_variance QUOTE ident { Some (mkrhs $3 3), $1 } | type_variance UNDERSCORE { None, $1 } ; optional_type_parameter_list: @@ -1448,7 +1427,7 @@ type_parameters: | LPAREN type_parameter_list RPAREN { List.rev $2 } ; type_parameter: - type_variance QUOTE ident { $3, $1 } + type_variance QUOTE ident { mkrhs $3 3, $1 } ; type_variance: /* empty */ { false, false } @@ -1467,7 +1446,7 @@ constructor_declaration: | constr_ident generalized_constructor_arguments { let arg_types,ret_type = $2 in - ($1, arg_types,ret_type, symbol_rloc()) } + (mkrhs $1 1, arg_types,ret_type, symbol_rloc()) } ; constructor_arguments: @@ -1490,7 +1469,7 @@ label_declarations: | label_declarations SEMI label_declaration { $3 :: $1 } ; label_declaration: - mutable_flag label COLON poly_type { ($2, $1, $4, symbol_rloc()) } + mutable_flag label COLON poly_type { (mkrhs $2 2, $1, $4, symbol_rloc()) } ; /* "with" constraints (additional type equations over signature components) */ @@ -1502,7 +1481,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 = List.map (fun x -> Some x) params; + (mkrhs $3 3, Pwith_type {ptype_params = List.map (fun x -> Some x) params; ptype_cstrs = List.rev $6; ptype_kind = Ptype_abstract; ptype_manifest = Some $5; @@ -1513,7 +1492,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 = List.map (fun x -> Some x) params; + (mkrhs $3 3, Pwith_typesubst {ptype_params = List.map (fun x -> Some x) params; ptype_cstrs = []; ptype_kind = Ptype_abstract; ptype_manifest = Some $5; @@ -1521,9 +1500,9 @@ with_constraint: ptype_variance = variance; ptype_loc = symbol_rloc()}) } | MODULE mod_longident EQUAL mod_ext_longident - { ($2, Pwith_module $4) } + { (mkrhs $2 2, Pwith_module (mkrhs $4 4)) } | MODULE mod_longident COLONEQUAL mod_ext_longident - { ($2, Pwith_modsubst $4) } + { (mkrhs $2 2, Pwith_modsubst (mkrhs $4 4)) } ; with_type_binder: EQUAL { Public } @@ -1555,13 +1534,9 @@ core_type2: simple_core_type_or_tuple { $1 } | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); - ptyp_loc = $4.ptyp_loc}, $6)) } + { mktyp(Ptyp_arrow("?" ^ $2 , mkoption $4, $6)) } | OPTLABEL core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); - ptyp_loc = $2.ptyp_loc}, $4)) } + { mktyp(Ptyp_arrow("?" ^ $1 , mkoption $2, $4)) } | LIDENT COLON core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow($1, $3, $5)) } | core_type2 MINUSGREATER core_type2 @@ -1580,21 +1555,21 @@ simple_core_type2: | UNDERSCORE { mktyp(Ptyp_any) } | type_longident - { mktyp(Ptyp_constr($1, [])) } + { mktyp(Ptyp_constr(mkrhs $1 1, [])) } | simple_core_type2 type_longident - { mktyp(Ptyp_constr($2, [$1])) } + { mktyp(Ptyp_constr(mkrhs $2 2, [$1])) } | LPAREN core_type_comma_list RPAREN type_longident - { mktyp(Ptyp_constr($4, List.rev $2)) } + { mktyp(Ptyp_constr(mkrhs $4 4, List.rev $2)) } | LESS meth_list GREATER { mktyp(Ptyp_object $2) } | LESS GREATER { mktyp(Ptyp_object []) } | SHARP class_longident opt_present - { mktyp(Ptyp_class($2, [], $3)) } + { mktyp(Ptyp_class(mkrhs $2 2, [], $3)) } | simple_core_type2 SHARP class_longident opt_present - { mktyp(Ptyp_class($3, [$1], $4)) } + { mktyp(Ptyp_class(mkrhs $3 3, [$1], $4)) } | LPAREN core_type_comma_list RPAREN SHARP class_longident opt_present - { mktyp(Ptyp_class($5, List.rev $2, $6)) } + { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2, $6)) } | LBRACKET tag_field RBRACKET { mktyp(Ptyp_variant([$2], true, None)) } /* PR#3835: this is not LR(1), would need lookahead=2 @@ -1617,11 +1592,11 @@ simple_core_type2: { mktyp(Ptyp_package $3) } ; package_type: - mty_longident { ($1, []) } - | mty_longident WITH package_type_cstrs { ($1, $3) } + mty_longident { (mkrhs $1 1, []) } + | mty_longident WITH package_type_cstrs { (mkrhs $1 1, $3) } ; package_type_cstr: - TYPE label_longident EQUAL core_type { ($2, $4) } + TYPE label_longident EQUAL core_type { (mkrhs $2 2, $4) } ; package_type_cstrs: package_type_cstr { [$1] } @@ -1789,6 +1764,14 @@ class_longident: LIDENT { Lident $1 } | mod_longident DOT LIDENT { Ldot($1, $3) } ; +any_longident: + val_ident { Lident $1 } + | mod_ext_longident DOT val_ident { Ldot ($1, $3) } + | mod_ext_longident { $1 } + | LBRACKET RBRACKET { Lident "[]" } + | LPAREN RPAREN { Lident "()" } + | FALSE { Lident "false" } + | TRUE { Lident "true" } /* Toplevel directives */ @@ -1846,15 +1829,19 @@ subtractive: /* > JOCAML */ joinident: - | LIDENT { { pjident_desc=$1 ; pjident_loc=symbol_rloc () } } + | LIDENT { mkrhs $1 1 } ; joinpattern: | joinident LPAREN pattern RPAREN { { pjpat_desc=$1,$3 ; pjpat_loc=symbol_rloc () } } | joinident LPAREN RPAREN - { { pjpat_desc=$1,mkpat(Ppat_construct(Lident "()", None, false)) ; pjpat_loc=symbol_rloc () } } -; + { + let loc = symbol_rloc () in + { pjpat_desc= + $1,mkpat(Ppat_construct(mkloc (Lident "()") loc, None, false)); + pjpat_loc=loc; } + } ; joinpattern_list_AMP: | joinpattern_list_AMP AMPERSAND joinpattern { $3 :: $1 } | joinpattern { [$1] } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 15974ae655..a01c2d1308 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -27,15 +27,16 @@ and core_type_desc = | Ptyp_var of string | Ptyp_arrow of label * core_type * core_type | Ptyp_tuple of core_type list - | Ptyp_constr of Longident.t * core_type list + | Ptyp_constr of Longident.t loc * core_type list | Ptyp_object of core_field_type list - | Ptyp_class of Longident.t * core_type list * label list + | Ptyp_class of Longident.t loc * core_type list * label list | Ptyp_alias of core_type * string | Ptyp_variant of row_field list * bool * label list option | Ptyp_poly of string list * core_type | Ptyp_package of package_type -and package_type = Longident.t * (Longident.t * core_type) list + +and package_type = Longident.t loc * (Longident.t loc * core_type) list and core_field_type = { pfield_desc: core_field_desc; @@ -53,8 +54,8 @@ and row_field = type 'a class_infos = { pci_virt: virtual_flag; - pci_params: string list * Location.t; - pci_name: string; + pci_params: string loc list * Location.t; + pci_name: string loc; pci_expr: 'a; pci_variance: (bool * bool) list; pci_loc: Location.t } @@ -67,26 +68,26 @@ type pattern = and pattern_desc = Ppat_any - | Ppat_var of string - | Ppat_alias of pattern * string + | Ppat_var of string loc + | Ppat_alias of pattern * string loc | Ppat_constant of constant | Ppat_tuple of pattern list - | Ppat_construct of Longident.t * pattern option * bool + | Ppat_construct of Longident.t loc * pattern option * bool | Ppat_variant of label * pattern option - | Ppat_record of (Longident.t * pattern) list * closed_flag + | Ppat_record of (Longident.t loc * pattern) list * closed_flag | Ppat_array of pattern list | Ppat_or of pattern * pattern | Ppat_constraint of pattern * core_type - | Ppat_type of Longident.t + | Ppat_type of Longident.t loc | Ppat_lazy of pattern - | Ppat_unpack of string + | Ppat_unpack of string loc type expression = { pexp_desc: expression_desc; pexp_loc: Location.t } and expression_desc = - Pexp_ident of Longident.t + Pexp_ident of Longident.t loc | Pexp_constant of constant | Pexp_let of rec_flag * (pattern * expression) list * expression | Pexp_function of label * expression option * (pattern * expression) list @@ -94,23 +95,23 @@ and expression_desc = | Pexp_match of expression * (pattern * expression) list | Pexp_try of expression * (pattern * expression) list | Pexp_tuple of expression list - | Pexp_construct of Longident.t * expression option * bool + | Pexp_construct of Longident.t loc * expression option * bool | Pexp_variant of label * expression option - | Pexp_record of (Longident.t * expression) list * expression option - | Pexp_field of expression * Longident.t - | Pexp_setfield of expression * Longident.t * expression + | Pexp_record of (Longident.t loc * expression) list * expression option + | Pexp_field of expression * Longident.t loc + | Pexp_setfield of expression * Longident.t loc * expression | Pexp_array of expression list | Pexp_ifthenelse of expression * expression * expression option | Pexp_sequence of expression * expression | Pexp_while of expression * expression - | Pexp_for of string * expression * expression * direction_flag * expression + | Pexp_for of string loc * expression * expression * direction_flag * expression | Pexp_constraint of expression * core_type option * core_type option | Pexp_when of expression * expression | Pexp_send of expression * string - | Pexp_new of Longident.t - | Pexp_setinstvar of string * expression - | Pexp_override of (string * expression) list - | Pexp_letmodule of string * module_expr * expression + | Pexp_new of Longident.t loc + | Pexp_setinstvar of string loc * expression + | Pexp_override of (string loc * expression) list + | Pexp_letmodule of string loc * module_expr * expression | Pexp_assert of expression | Pexp_assertfalse | Pexp_lazy of expression @@ -118,7 +119,7 @@ and expression_desc = | Pexp_object of class_structure | Pexp_newtype of string * expression | Pexp_pack of module_expr - | Pexp_open of Longident.t * expression + | Pexp_open of Longident.t loc * expression (*> JOCAML *) | Pexp_spawn of expression | Pexp_par of expression * expression @@ -137,7 +138,7 @@ and joinpattern = { pjpat_desc: joinpattern_desc; pjpat_loc: Location.t} -and joinident = {pjident_desc : string ; pjident_loc : Location.t} +and joinident = string loc and joinpattern_desc = joinident * pattern @@ -147,12 +148,14 @@ and joinpattern_desc = joinident * pattern and value_description = { pval_type: core_type; - pval_prim: string list } + pval_prim: string list; + pval_loc : Location.t + } (* Type declarations *) and type_declaration = - { ptype_params: string option list; + { ptype_params: string loc option list; ptype_cstrs: (core_type * core_type * Location.t) list; ptype_kind: type_kind; ptype_private: private_flag; @@ -163,9 +166,9 @@ and type_declaration = and type_kind = Ptype_abstract | Ptype_variant of - (string * core_type list * core_type option * Location.t) list + (string loc * core_type list * core_type option * Location.t) list | Ptype_record of - (string * mutable_flag * core_type * Location.t) list + (string loc * mutable_flag * core_type * Location.t) list and exception_declaration = core_type list @@ -176,18 +179,27 @@ and class_type = pcty_loc: Location.t } and class_type_desc = - Pcty_constr of Longident.t * core_type list + Pcty_constr of Longident.t loc * core_type list | Pcty_signature of class_signature | Pcty_fun of label * core_type * class_type -and class_signature = core_type * class_type_field list +and class_signature = { + pcsig_self : core_type; + pcsig_fields : class_type_field list; + pcsig_loc : Location.t; + } + +and class_type_field = { + pctf_desc : class_type_field_desc; + pctf_loc : Location.t; + } -and class_type_field = +and class_type_field_desc = Pctf_inher of class_type - | 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) + | Pctf_val of (string * mutable_flag * virtual_flag * core_type) + | Pctf_virt of (string * private_flag * core_type) + | Pctf_meth of (string * private_flag * core_type) + | Pctf_cstr of (core_type * core_type) and class_description = class_type class_infos @@ -200,25 +212,31 @@ and class_expr = pcl_loc: Location.t } and class_expr_desc = - Pcl_constr of Longident.t * core_type list + Pcl_constr of Longident.t loc * core_type list | Pcl_structure of class_structure | Pcl_fun of label * expression option * pattern * class_expr | Pcl_apply of class_expr * (label * expression) list | Pcl_let of rec_flag * (pattern * expression) list * class_expr | Pcl_constraint of class_expr * class_type -and class_structure = pattern * class_field list +and class_structure = { + pcstr_pat : pattern; + pcstr_fields : class_field list; + } + +and class_field = { + pcf_desc : class_field_desc; + pcf_loc : Location.t; + } -and class_field = +and class_field_desc = 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_init of expression + | Pcf_valvirt of (string loc * mutable_flag * core_type) + | Pcf_val of (string loc * mutable_flag * override_flag * expression) + | Pcf_virt of (string loc * private_flag * core_type) + | Pcf_meth of (string loc * private_flag *override_flag * expression) + | Pcf_constr of (core_type * core_type) + | Pcf_init of expression and class_declaration = class_expr class_infos @@ -229,10 +247,10 @@ and module_type = pmty_loc: Location.t } and module_type_desc = - Pmty_ident of Longident.t + Pmty_ident of Longident.t loc | Pmty_signature of signature - | Pmty_functor of string * module_type * module_type - | Pmty_with of module_type * (Longident.t * with_constraint) list + | Pmty_functor of string loc * module_type * module_type + | Pmty_with of module_type * (Longident.t loc * with_constraint) list | Pmty_typeof of module_expr and signature = signature_item list @@ -242,13 +260,13 @@ and signature_item = psig_loc: Location.t } and signature_item_desc = - Psig_value of string * value_description - | Psig_type of (string * type_declaration) list - | Psig_exception of string * exception_declaration - | Psig_module of string * module_type - | Psig_recmodule of (string * module_type) list - | Psig_modtype of string * modtype_declaration - | Psig_open of Longident.t + Psig_value of string loc * value_description + | Psig_type of (string loc * type_declaration) list + | Psig_exception of string loc * exception_declaration + | Psig_module of string loc * module_type + | Psig_recmodule of (string loc * module_type) list + | Psig_modtype of string loc * modtype_declaration + | Psig_open of Longident.t loc | Psig_include of module_type | Psig_class of class_description list | Psig_class_type of class_type_declaration list @@ -259,9 +277,9 @@ and modtype_declaration = and with_constraint = Pwith_type of type_declaration - | Pwith_module of Longident.t + | Pwith_module of Longident.t loc | Pwith_typesubst of type_declaration - | Pwith_modsubst of Longident.t + | Pwith_modsubst of Longident.t loc (* Value expressions for the module language *) @@ -270,9 +288,9 @@ and module_expr = pmod_loc: Location.t } and module_expr_desc = - Pmod_ident of Longident.t + Pmod_ident of Longident.t loc | Pmod_structure of structure - | Pmod_functor of string * module_type * module_expr + | Pmod_functor of string loc * module_type * module_expr | Pmod_apply of module_expr * module_expr | Pmod_constraint of module_expr * module_type | Pmod_unpack of expression @@ -286,20 +304,20 @@ and structure_item = and structure_item_desc = Pstr_eval of expression | Pstr_value of rec_flag * (pattern * expression) list - | Pstr_primitive of string * value_description - | Pstr_type of (string * type_declaration) list - | Pstr_exception of string * exception_declaration - | Pstr_exn_rebind of string * Longident.t - | Pstr_module of string * module_expr - | Pstr_recmodule of (string * module_type * module_expr) list - | Pstr_modtype of string * module_type - | Pstr_open of Longident.t + | Pstr_primitive of string loc * value_description + | Pstr_type of (string loc * type_declaration) list + | Pstr_exception of string loc * exception_declaration + | Pstr_exn_rebind of string loc * Longident.t loc + | Pstr_module of string loc * module_expr + | Pstr_recmodule of (string loc * module_type * module_expr) list + | Pstr_modtype of string loc * module_type + | Pstr_open of Longident.t loc | Pstr_class of class_declaration list | Pstr_class_type of class_type_declaration list | Pstr_include of module_expr (*> JOCAML *) | Pstr_def of joinautomaton list - | Pstr_exn_global of Longident.t + | Pstr_exn_global of Longident.t loc (*< JOCAML *) (* Toplevel phrases *) diff --git a/parsing/printast.ml b/parsing/printast.ml index b66a891653..34b74c6096 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -38,14 +38,8 @@ let rec fmt_longident_aux f x = fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; ;; -let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;; - -(*> JOCAML *) -let fmt_joinident f x = fprintf f "\"%s\"" x -and fmt_joinarg f = function - | None -> fprintf f "\"_\"" - | Some x -> fprintf f "\"%s\"" x;; -(*< JOCAML *) +let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;; +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; let fmt_constant f x = match x with @@ -119,17 +113,10 @@ let option i f ppf x = let longident i ppf li = line i ppf "%a\n" fmt_longident li;; let string i ppf s = line i ppf "\"%s\"\n" s;; +let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;; let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; let label i ppf x = line i ppf "label=\"%s\"\n" x;; -(*> JOCAML *) -let joinident i ppf ji = - line i ppf "joinident %a\n" fmt_location ji.pjident_loc; - let i = i+1 in - line i ppf "%a\n" fmt_joinident ji.pjident_desc -;; -(*< JOCAML *) - let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; @@ -188,9 +175,9 @@ and pattern i ppf x = let i = i+1 in match x.ppat_desc with | Ppat_any -> line i ppf "Ppat_any\n"; - | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s; + | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s.txt; | Ppat_alias (p, s) -> - line i ppf "Ppat_alias \"%s\"\n" s; + line i ppf "Ppat_alias \"%s\"\n" s.txt; pattern i ppf p; | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; | Ppat_tuple (l) -> @@ -220,11 +207,11 @@ and pattern i ppf x = line i ppf "Ppat_constraint"; pattern i ppf p; core_type i ppf ct; - | Ppat_type li -> + | Ppat_type (li) -> line i ppf "Ppat_type"; longident i ppf li | Ppat_unpack s -> - line i ppf "Ppat_unpack \"%s\"\n" s; + line i ppf "Ppat_unpack \"%s\"\n" s.txt; and expression i ppf x = line i ppf "expression %a\n" fmt_location x.pexp_loc; @@ -292,7 +279,7 @@ and expression i ppf x = expression i ppf e1; expression i ppf e2; | Pexp_for (s, e1, e2, df, e3) -> - line i ppf "Pexp_for \"%s\" %a\n" s fmt_direction_flag df; + line i ppf "Pexp_for \"%s\" %a\n" s.txt fmt_direction_flag df; expression i ppf e1; expression i ppf e2; expression i ppf e3; @@ -310,13 +297,13 @@ and expression i ppf x = expression i ppf e; | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li; | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar \"%s\"\n" s; + line i ppf "Pexp_setinstvar \"%s\"\n" s.txt; expression i ppf e; | Pexp_override (l) -> line i ppf "Pexp_override\n"; list i string_x_expression ppf l; | Pexp_letmodule (s, me, e) -> - line i ppf "Pexp_letmodule \"%s\"\n" s; + line i ppf "Pexp_letmodule \"%s\"\n" s.txt; module_expr i ppf me; expression i ppf e; | Pexp_assert (e) -> @@ -354,7 +341,7 @@ and expression i ppf x = | Pexp_reply (e, id) -> line i ppf "Pexp_reply\n"; expression i ppf e; - joinident i ppf id; + string_loc i ppf id; | Pexp_def (d,e) -> line i ppf "Pexp_def\n"; joindefinition i ppf d; @@ -378,7 +365,7 @@ and joinpattern i ppf jpat = line i ppf "joinpattern %a\n" fmt_location jpat.pjpat_loc; let i = i+1 in let chan,pat = jpat.pjpat_desc in - joinident i ppf chan ; + string_loc i ppf chan ; pattern i ppf pat (*< JOCAML *) @@ -387,10 +374,10 @@ 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 = +and string_option_underscore i ppf = function | Some x -> - string i ppf x + string i ppf x.txt | None -> string i ppf "_" @@ -435,30 +422,31 @@ and class_type i ppf x = core_type i ppf co; class_type i ppf cl; -and class_signature i ppf (ct, l) = +and class_signature i ppf { pcsig_self = ct; pcsig_fields = l } = line i ppf "class_signature\n"; core_type (i+1) ppf ct; list (i+1) class_type_field ppf l; and class_type_field i ppf x = - match x with + let loc = x.pctf_loc in + match x.pctf_desc with | Pctf_inher (ct) -> line i ppf "Pctf_inher\n"; class_type i ppf ct; - | Pctf_val (s, mf, vf, ct, loc) -> + | Pctf_val (s, mf, vf, ct) -> line i ppf "Pctf_val \"%s\" %a %a %a\n" s fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; core_type (i+1) ppf ct; - | Pctf_virt (s, pf, ct, loc) -> + | Pctf_virt (s, pf, ct) -> line i ppf "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; - | Pctf_meth (s, pf, ct, loc) -> + | Pctf_meth (s, pf, ct) -> line i ppf "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; - | Pctf_cstr (ct1, ct2, loc) -> + | Pctf_cstr (ct1, ct2) -> line i ppf "Pctf_cstr %a\n" fmt_location loc; core_type i ppf ct1; core_type i ppf ct2; @@ -469,7 +457,7 @@ and class_description i ppf x = line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.pci_params; - line i ppf "pci_name = \"%s\"\n" x.pci_name; + line i ppf "pci_name = \"%s\"\n" x.pci_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.pci_expr; @@ -479,7 +467,7 @@ and class_type_declaration i ppf x = line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.pci_params; - line i ppf "pci_name = \"%s\"\n" x.pci_name; + line i ppf "pci_name = \"%s\"\n" x.pci_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.pci_expr; @@ -512,35 +500,36 @@ and class_expr i ppf x = class_expr i ppf ce; class_type i ppf ct; -and class_structure i ppf (p, l) = +and class_structure i ppf { pcstr_pat = p; pcstr_fields = l } = line i ppf "class_structure\n"; pattern (i+1) ppf p; list (i+1) class_field ppf l; and class_field i ppf x = - match x with + let loc = x.pcf_loc in + match x.pcf_desc with | Pcf_inher (ovf, ce, so) -> line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; - | Pcf_valvirt (s, mf, ct, loc) -> + | Pcf_valvirt (s, mf, ct) -> line i ppf "Pcf_valvirt \"%s\" %a %a\n" - s fmt_mutable_flag mf fmt_location loc; + s.txt fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; - | Pcf_val (s, mf, ovf, e, loc) -> + | Pcf_val (s, mf, ovf, e) -> line i ppf "Pcf_val \"%s\" %a %a %a\n" - s fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; + s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; - | Pcf_virt (s, pf, ct, loc) -> + | Pcf_virt (s, pf, ct) -> line i ppf "Pcf_virt \"%s\" %a %a\n" - s fmt_private_flag pf fmt_location loc; + s.txt fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; - | Pcf_meth (s, pf, ovf, e, loc) -> + | Pcf_meth (s, pf, ovf, e) -> line i ppf "Pcf_meth \"%s\" %a %a %a\n" - s fmt_private_flag pf fmt_override_flag ovf fmt_location loc; + s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; - | Pcf_cstr (ct1, ct2, loc) -> - line i ppf "Pcf_cstr %a\n" fmt_location loc; + | Pcf_constr (ct1, ct2) -> + line i ppf "Pcf_constr %a\n" fmt_location loc; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; | Pcf_init (e) -> @@ -553,7 +542,7 @@ and class_declaration i ppf x = line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.pci_params; - line i ppf "pci_name = \"%s\"\n" x.pci_name; + line i ppf "pci_name = \"%s\"\n" x.pci_name.txt; line i ppf "pci_expr =\n"; class_expr (i+1) ppf x.pci_expr; @@ -561,12 +550,12 @@ and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.pmty_loc; let i = i+1 in match x.pmty_desc with - | Pmty_ident (li) -> line i ppf "Pmty_ident %a\n" fmt_longident li; + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident li; | Pmty_signature (s) -> line i ppf "Pmty_signature\n"; signature i ppf s; | Pmty_functor (s, mt1, mt2) -> - line i ppf "Pmty_functor \"%s\"\n" s; + line i ppf "Pmty_functor \"%s\"\n" s.txt; module_type i ppf mt1; module_type i ppf mt2; | Pmty_with (mt, l) -> @@ -584,24 +573,24 @@ and signature_item i ppf x = let i = i+1 in match x.psig_desc with | Psig_value (s, vd) -> - line i ppf "Psig_value \"%s\"\n" s; + line i ppf "Psig_value \"%s\"\n" s.txt; value_description i ppf vd; | Psig_type (l) -> line i ppf "Psig_type\n"; list i string_x_type_declaration ppf l; | Psig_exception (s, ed) -> - line i ppf "Psig_exception \"%s\"\n" s; + line i ppf "Psig_exception \"%s\"\n" s.txt; exception_declaration i ppf ed; | Psig_module (s, mt) -> - line i ppf "Psig_module \"%s\"\n" s; + line i ppf "Psig_module \"%s\"\n" s.txt; module_type i ppf mt; | Psig_recmodule decls -> line i ppf "Psig_recmodule\n"; list i string_x_module_type ppf decls; | Psig_modtype (s, md) -> - line i ppf "Psig_modtype \"%s\"\n" s; + line i ppf "Psig_modtype \"%s\"\n" s.txt; modtype_declaration i ppf md; - | Psig_open (li) -> line i ppf "Psig_open %a\n" fmt_longident li; + | Psig_open li -> line i ppf "Psig_open %a\n" fmt_longident li; | Psig_include (mt) -> line i ppf "Psig_include\n"; module_type i ppf mt; @@ -627,8 +616,8 @@ and with_constraint i ppf x = | Pwith_typesubst (td) -> line i ppf "Pwith_typesubst\n"; type_declaration (i+1) ppf td; - | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li; - | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li; + | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident li; + | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident li; and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.pmod_loc; @@ -639,7 +628,7 @@ and module_expr i ppf x = line i ppf "Pmod_structure\n"; structure i ppf s; | Pmod_functor (s, mt, me) -> - line i ppf "Pmod_functor \"%s\"\n" s; + line i ppf "Pmod_functor \"%s\"\n" s.txt; module_type i ppf mt; module_expr i ppf me; | Pmod_apply (me1, me2) -> @@ -674,26 +663,26 @@ and structure_item i ppf x = line i ppf "Pstr_exn_global %a\n" fmt_longident li (*<JOCAML*) | Pstr_primitive (s, vd) -> - line i ppf "Pstr_primitive \"%s\"\n" s; + line i ppf "Pstr_primitive \"%s\"\n" s.txt; value_description i ppf vd; - | Pstr_type (l) -> + | Pstr_type l -> line i ppf "Pstr_type\n"; list i string_x_type_declaration ppf l; | Pstr_exception (s, ed) -> - line i ppf "Pstr_exception \"%s\"\n" s; + line i ppf "Pstr_exception \"%s\"\n" s.txt; exception_declaration i ppf ed; | Pstr_exn_rebind (s, li) -> - line i ppf "Pstr_exn_rebind \"%s\" %a\n" s fmt_longident li; + line i ppf "Pstr_exn_rebind \"%s\" %a\n" s.txt fmt_longident li; | Pstr_module (s, me) -> - line i ppf "Pstr_module \"%s\"\n" s; + line i ppf "Pstr_module \"%s\"\n" s.txt; module_expr i ppf me; | Pstr_recmodule bindings -> line i ppf "Pstr_recmodule\n"; list i string_x_modtype_x_module ppf bindings; | Pstr_modtype (s, mt) -> - line i ppf "Pstr_modtype \"%s\"\n" s; + line i ppf "Pstr_modtype \"%s\"\n" s.txt; module_type i ppf mt; - | Pstr_open (li) -> line i ppf "Pstr_open %a\n" fmt_longident li; + | Pstr_open li -> line i ppf "Pstr_open %a\n" fmt_longident li; | Pstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf l; @@ -705,15 +694,15 @@ and structure_item i ppf x = module_expr i ppf me and string_x_type_declaration i ppf (s, td) = - string i ppf s; + string i ppf s.txt; type_declaration (i+1) ppf td; and string_x_module_type i ppf (s, mty) = - string i ppf s; + string i ppf s.txt; module_type (i+1) ppf mty; and string_x_modtype_x_module i ppf (s, mty, modl) = - string i ppf s; + string i ppf s.txt; module_type (i+1) ppf mty; module_expr (i+1) ppf modl; @@ -726,18 +715,18 @@ 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, r_opt, loc) = - line i ppf "\"%s\" %a\n" s fmt_location loc; +and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) = + line i ppf "\"%s\" %a\n" s.txt fmt_location loc; 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; + line i ppf "\"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; and string_list_x_location i ppf (l, loc) = line i ppf "<params> %a\n" fmt_location loc; - list (i+1) string ppf l; + list (i+1) string_loc ppf l; and longident_x_pattern i ppf (li, p) = line i ppf "%a\n" fmt_longident li; @@ -754,7 +743,7 @@ and pattern_x_expression_def i ppf (p, e) = expression (i+1) ppf e; and string_x_expression i ppf (s, e) = - line i ppf "<override> \"%s\"\n" s; + line i ppf "<override> \"%s\"\n" s.txt; expression (i+1) ppf e; and longident_x_expression i ppf (li, e) = @@ -789,7 +778,7 @@ and directive_argument i ppf x = | Pdir_none -> line i ppf "Pdir_none\n" | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i; - | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; + | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident_noloc li; | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); ;; diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index 29f0deb3aa..f18e3281d3 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -19,8 +19,10 @@ 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 @@ -41,5 +43,10 @@ let report_error ppf = function "%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 10a07d14c9..c2f9eb07c5 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -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/.depend b/stdlib/.depend index 3fd2959bc4..b8a837dbef 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -70,9 +70,9 @@ 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.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \ filename.cmi -filename.cmx : sys.cmx string.cmx random.cmx printf.cmx buffer.cmx \ +filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \ filename.cmi format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ buffer.cmi format.cmi @@ -82,8 +82,10 @@ 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 +hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \ + hashtbl.cmi +hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \ + hashtbl.cmi int32.cmo : pervasives.cmi int32.cmi int32.cmx : pervasives.cmx int32.cmi int64.cmo : pervasives.cmi int64.cmi @@ -178,9 +180,9 @@ 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.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \ filename.cmi -filename.p.cmx : sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx buffer.p.cmx \ +filename.p.cmx : sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx lazy.p.cmx buffer.p.cmx \ filename.cmi format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ buffer.cmi format.cmi @@ -190,8 +192,10 @@ 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 +hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \ + hashtbl.cmi +hashtbl.p.cmx : sys.p.cmx string.p.cmx random.p.cmx obj.p.cmx lazy.p.cmx array.p.cmx \ + hashtbl.cmi int32.cmo : pervasives.cmi int32.cmi int32.p.cmx : pervasives.p.cmx int32.cmi int64.cmo : pervasives.cmi int64.cmi diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 28d3287ca7..4709372e36 100755 --- a/stdlib/Makefile.shared +++ b/stdlib/Makefile.shared @@ -25,14 +25,14 @@ CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ - hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ + sort.cmo marshal.cmo obj.cmo \ int32.cmo int64.cmo nativeint.cmo \ lexing.cmo parsing.cmo \ set.cmo map.cmo stack.cmo queue.cmo \ camlinternalLazy.cmo lazy.cmo stream.cmo \ - buffer.cmo printf.cmo format.cmo scanf.cmo \ + buffer.cmo printf.cmo \ arg.cmo printexc.cmo gc.cmo \ - digest.cmo random.cmo callback.cmo \ + digest.cmo random.cmo hashtbl.cmo format.cmo scanf.cmo callback.cmo \ camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ genlex.cmo weak.cmo \ filename.cmo complex.cmo \ diff --git a/stdlib/array.mli b/stdlib/array.mli index df5b1c41c6..db1f469d0e 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -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.mli b/stdlib/arrayLabels.mli index d4833e0269..308bfa4e1c 100644 --- a/stdlib/arrayLabels.mli +++ b/stdlib/arrayLabels.mli @@ -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/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli index 99de7ed84f..eef1c9d6fd 100644 --- a/stdlib/camlinternalLazy.mli +++ b/stdlib/camlinternalLazy.mli @@ -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.mli b/stdlib/camlinternalMod.mli index dc8c61ca06..bc59f19564 100644 --- a/stdlib/camlinternalMod.mli +++ b/stdlib/camlinternalMod.mli @@ -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/char.mli b/stdlib/char.mli index 34bd6c23d0..05a8156d3c 100644 --- a/stdlib/char.mli +++ b/stdlib/char.mli @@ -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/filename.ml b/stdlib/filename.ml index 8c3ad53155..950a7b39fd 100644 --- a/stdlib/filename.ml +++ b/stdlib/filename.ml @@ -210,14 +210,19 @@ let chop_extension name = external open_desc: string -> open_flag list -> int -> int = "caml_sys_open" external close_desc: int -> unit = "caml_sys_close" -let prng = Random.State.make_self_init ();; +let prng = lazy(Random.State.make_self_init ());; let temp_file_name temp_dir prefix suffix = - let rnd = (Random.State.bits prng) land 0xFFFFFF in + let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in 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 @@ -227,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 b4644ad67d..499e8bb291 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -79,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 @@ -102,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/gc.mli b/stdlib/gc.mli index 71b8ffa783..45d882f25a 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -158,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. *) diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml index 6f3ea880b6..80a0399592 100644 --- a/stdlib/hashtbl.ml +++ b/stdlib/hashtbl.ml @@ -28,26 +28,56 @@ let seeded_hash seed x = seeded_hash_param 10 100 seed x type ('a, 'b) t = { mutable size: int; (* number of entries *) mutable data: ('a, 'b) bucketlist array; (* the buckets *) - mutable seed: int } (* for randomization *) + mutable seed: int; (* for randomization *) + initial_size: int; (* initial array size *) + } and ('a, 'b) bucketlist = Empty | Cons of 'a * 'b * ('a, 'b) bucketlist +(* To pick random seeds if requested *) + +let randomized_default = + let params = + try Sys.getenv "OCAMLRUNPARAM" with Not_found -> + try Sys.getenv "CAMLRUNPARAM" with Not_found -> "" in + String.contains params 'R' + +let randomized = ref randomized_default + +let randomize () = randomized := true + +let prng = lazy (Random.State.make_self_init()) + +(* Creating a fresh, empty table *) + 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 create ?(random = !randomized) initial_size = let s = power_2_above 16 initial_size in - { size = 0; seed = seed; data = Array.make s Empty } + let seed = if random then Random.State.bits (Lazy.force prng) else 0 in + { initial_size = s; size = 0; seed = seed; data = Array.make s Empty } let clear h = - for i = 0 to Array.length h.data - 1 do + h.size <- 0; + let len = Array.length h.data in + for i = 0 to len - 1 do h.data.(i) <- Empty - done; - h.size <- 0 + done + +let reset h = + let len = Array.length h.data in + if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *) + || len = h.initial_size then + clear h + else begin + h.size <- 0; + h.data <- Array.make h.initial_size Empty + end let copy h = { h with data = Array.copy h.data } @@ -58,7 +88,7 @@ let resize indexfun h = let osize = Array.length odata in let nsize = osize * 2 in if nsize < Sys.max_array_length then begin - let ndata = Array.create nsize Empty in + let ndata = Array.make nsize Empty in h.data <- ndata; (* so that indexfun sees the new bucket count *) let rec insert_bucket = function Empty -> () @@ -73,7 +103,7 @@ let resize indexfun h = let key_index h key = (* compatibility with old hash tables *) - if Obj.size (Obj.repr h) = 3 + 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) @@ -221,7 +251,8 @@ module type S = type key type 'a t val create: int -> 'a t - val clear: 'a t -> unit + val clear : 'a t -> unit + val reset : 'a t -> unit val copy: 'a t -> 'a t val add: 'a t -> key -> 'a -> unit val remove: 'a t -> key -> unit @@ -239,8 +270,9 @@ module type SeededS = sig type key type 'a t - val create : ?seed:int -> int -> 'a t + val create : ?random:bool -> int -> 'a t val clear : 'a t -> unit + val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit @@ -261,6 +293,7 @@ module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) = type 'a t = 'a hashtbl let create = create let clear = clear + let reset = reset let copy = copy let key_index h key = @@ -352,5 +385,5 @@ module Make(H: HashedType): (S with type key = H.t) = let equal = H.equal let hash (seed: int) x = H.hash x end) - let create sz = create ~seed:0 sz + let create sz = create ~random:false sz end diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index 98d03198f5..00d9efca37 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -25,26 +25,55 @@ type ('a, 'b) t (** The type of hash tables from type ['a] to type ['b]. *) -val create : ?seed:int -> int -> ('a, 'b) t +val create : ?random:bool -> 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. - 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. *) + The optional [random] parameter (a boolean) controls whether + the internal organization of the hash table is randomized at each + execution of [Hashtbl.create] or deterministic over all executions. + + A hash table that is created with [~random:false] uses a + fixed hash function ({!Hashtbl.hash}) to distribute keys among + buckets. As a consequence, collisions between keys happen + deterministically. In Web-facing applications or other + security-sensitive applications, the deterministic collision + patterns can be exploited by a malicious user to create a + denial-of-service attack: the attacker sends input crafted to + create many collisions in the table, slowing the application down. + + A hash table that is created with [~random:true] uses the seeded + hash function {!Hashtbl.seeded_hash} with a seed that is randomly + chosen at hash table creation time. In effect, the hash function + used is randomly selected among [2^{30}] different hash functions. + All these hash functions have different collision patterns, + rendering ineffective the denial-of-service attack described above. + However, because of randomization, enumerating all elements of the + hash table using {!Hashtbl.fold} or {!Hashtbl.iter} is no longer + deterministic: elements are enumerated in different orders at + different runs of the program. + + If no [~random] parameter is given, hash tables are created + in non-random mode by default. This default can be changed + either programmatically by calling {!Hashtbl.randomize} or by + setting the [R] flag in the [OCAMLRUNPARAM] environment variable. + + @before 4.00.0 the [random] parameter was not present and all + hash tables were created in non-randomized mode. *) val clear : ('a, 'b) t -> unit -(** Empty a hash table. *) +(** Empty a hash table. Use [reset] instead of [clear] to shrink the + size of the bucket table to its initial size. *) +val reset : ('a, 'b) t -> unit +(** Empty a hash table and shrink the size of the bucket table + to its initial size. *) + +val copy : ('a, 'b) t -> ('a, 'b) t +(** Return a copy of the given hashtable. *) val add : ('a, 'b) t -> 'a -> 'b -> unit (** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl]. @@ -53,9 +82,6 @@ val add : ('a, 'b) t -> 'a -> 'b -> unit the previous binding for [x], if any, is restored. (Same behavior as with association lists.) *) -val copy : ('a, 'b) t -> ('a, 'b) t -(** Return a copy of the given hashtable. *) - val find : ('a, 'b) t -> 'a -> 'b (** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. *) @@ -85,10 +111,17 @@ val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl]. [f] receives the key as first argument, and the associated value as second argument. Each binding is presented exactly once to [f]. + The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, - the most recent binding is passed first. *) + the most recent binding is passed first. + + If the hash table was created in non-randomized mode, the order + in which the bindings are enumerated is reproducible between + successive runs of the program, and even between minor versions + of OCaml. For randomized hash tables, the order of enumeration + is entirely random. *) val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c (** [Hashtbl.fold f tbl init] computes @@ -96,11 +129,17 @@ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c where [k1 ... kN] are the keys of all bindings in [tbl], and [d1 ... dN] are the associated values. Each binding is presented exactly once to [f]. + The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, - the most recent binding is passed first. *) + the most recent binding is passed first. + If the hash table was created in non-randomized mode, the order + in which the bindings are enumerated is reproducible between + successive runs of the program, and even between minor versions + of OCaml. For randomized hash tables, the order of enumeration + is entirely random. *) val length : ('a, 'b) t -> int (** [Hashtbl.length tbl] returns the number of bindings in [tbl]. @@ -108,6 +147,25 @@ val length : ('a, 'b) t -> int [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its first argument. *) +val randomize : unit -> unit +(** After a call to [Hashtbl.randomize()], hash tables are created in + randomized mode by default: {!Hashtbl.create} returns randomized + hash tables, unless the [~random:false] optional parameter is given. + The same effect can be achieved by setting the [R] parameter in + the [OCAMLRUNPARAM] environment variable. + + It is recommended that applications or Web frameworks that need to + protect themselves against the denial-of-service attack described + in {!Hashtbl.create} call [Hashtbl.randomize()] at initialization + time. + + Note that once [Hashtbl.randomize()] was called, there is no way + to revert to the non-randomized default behavior of {!Hashtbl.create}. + This is intentional. Non-randomized hash tables can still be + created using [Hashtbl.create ~random:false]. + + @since 4.00.0 *) + type statistics = { num_bindings: int; (** Number of bindings present in the table. @@ -118,7 +176,7 @@ type statistics = { (** 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 + length [max_bucket_length + 1]. The value of [histo.(i)] is the number of buckets whose size is [i]. *) } @@ -159,6 +217,7 @@ module type S = type 'a t val create : int -> 'a t val clear : 'a t -> unit + val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit @@ -181,7 +240,9 @@ module Make (H : HashedType) : S with type key = H.t The operations perform similarly to those of the generic interface, but use the hashing and equality functions specified in the functor argument [H] instead of generic - equality and hashing. *) + equality and hashing. Since the hash function is not seeded, + the [create] operation of the result structure always returns + non-randomized hash tables. *) module type SeededHashedType = sig @@ -203,8 +264,9 @@ module type SeededS = sig type key type 'a t - val create : ?seed:int -> int -> 'a t + val create : ?random:bool -> int -> 'a t val clear : 'a t -> unit + val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit @@ -228,7 +290,10 @@ module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t 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. + equality and hashing. The [create] operation of the + result structure supports the [~random] optional parameter + and returns randomized hash tables if [~random:true] is passed + or if randomization is globally on (see {!Hashtbl.randomize}). @since 4.00.0 *) diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index 6134e1e593..9d720d2bbc 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -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, diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 2591b5c185..a1a0690169 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -152,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/map.ml b/stdlib/map.ml index 519ef824e7..78b76b0256 100644 --- a/stdlib/map.ml +++ b/stdlib/map.ml @@ -273,14 +273,20 @@ module Make(Ord: OrderedType) = struct 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' + (* call [p] in the expected left-to-right order *) + let l' = filter p l in + let pvd = p v d in + let r' = filter p r in + if pvd then 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 + (* call [p] in the expected left-to-right order *) + let (lt, lf) = partition p l in + let pvd = p v d in + let (rt, rf) = partition p r in + if pvd then (join lt v d rt, concat lf rf) else (concat lt rt, join lf v d rf) diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli index c2691cba5f..a004bdb5bf 100644 --- a/stdlib/moreLabels.mli +++ b/stdlib/moreLabels.mli @@ -25,10 +25,11 @@ module Hashtbl : sig type ('a, 'b) t = ('a, 'b) Hashtbl.t - val create : ?seed:int -> int -> ('a, 'b) t + val create : ?random:bool -> int -> ('a, 'b) t val clear : ('a, 'b) t -> unit - val add : ('a, 'b) t -> key:'a -> data:'b -> unit + val reset : ('a, 'b) t -> unit val copy : ('a, 'b) t -> ('a, 'b) t + val add : ('a, 'b) t -> key:'a -> data:'b -> unit val find : ('a, 'b) t -> 'a -> 'b val find_all : ('a, 'b) t -> 'a -> 'b list val mem : ('a, 'b) t -> 'a -> bool @@ -39,6 +40,7 @@ module Hashtbl : sig f:(key:'a -> data:'b -> 'c -> 'c) -> ('a, 'b) t -> init:'c -> 'c val length : ('a, 'b) t -> int + val randomize : unit -> unit type statistics = Hashtbl.statistics val stats : ('a, 'b) t -> statistics module type HashedType = Hashtbl.HashedType @@ -49,6 +51,7 @@ module Hashtbl : sig and 'a t val create : int -> 'a t val clear : 'a t -> unit + val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key:key -> data:'a -> unit val remove : 'a t -> key -> unit @@ -67,8 +70,9 @@ module Hashtbl : sig sig type key and 'a t - val create : ?seed:int -> int -> 'a t + val create : ?random:bool -> int -> 'a t val clear : 'a t -> unit + val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key:key -> data:'a -> unit val remove : 'a t -> key -> unit diff --git a/stdlib/oo.mli b/stdlib/oo.mli index 508217228b..2a9eb23209 100644 --- a/stdlib/oo.mli +++ b/stdlib/oo.mli @@ -30,6 +30,9 @@ external id : < .. > -> int = "%field1" *) (**/**) + +(* 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.mli b/stdlib/parsing.mli index 0d053b899e..f488245992 100644 --- a/stdlib/parsing.mli +++ b/stdlib/parsing.mli @@ -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.mli b/stdlib/pervasives.mli index fadc33ebfd..794c056855 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -508,7 +508,9 @@ val ( @ ) : 'a list -> 'a list -> 'a list (** List concatenation. *) -(** {6 Input/output} *) +(** {6 Input/output} + Note: all input/output functions can raise [Sys_error] when the system + calls they invoke fail. *) type in_channel (** The type of input channel. *) @@ -926,8 +928,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/printf.mli b/stdlib/printf.mli index 942ec49b05..6fcb45ebac 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -27,7 +27,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a 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 @@ -159,7 +159,7 @@ val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (**/**) -(* For OCaml 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/random.ml b/stdlib/random.ml index 44b8301501..800c629706 100644 --- a/stdlib/random.ml +++ b/stdlib/random.ml @@ -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 389ef8d218..d8ea01e621 100644 --- a/stdlib/random.mli +++ b/stdlib/random.mli @@ -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 37740765d5..b619bf8f05 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -483,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 @@ -1032,7 +1032,7 @@ let scan_range fmt j = scan_closing (j + 1) | _ -> scan_closing j in - let rec scan_first_neg j = + let scan_first_neg j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '^' -> diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 6e575d9099..6c24005306 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -79,10 +79,11 @@ 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 @@ -139,7 +140,7 @@ val open_in_bin : string -> in_channel;; *) val close_in : in_channel -> unit;; -(** Closes the [Pervasives.input_channel] associated with the given +(** Closes the [Pervasives.in_channel] associated with the given [Scanning.in_channel] formatted input channel. @since 3.12.0 *) diff --git a/stdlib/set.ml b/stdlib/set.ml index e61fd24b6a..661968be86 100644 --- a/stdlib/set.ml +++ b/stdlib/set.ml @@ -320,14 +320,20 @@ module Make(Ord: OrderedType) = 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' + (* call [p] in the expected left-to-right order *) + let l' = filter p l in + let pv = p v in + let r' = filter p r in + if pv then join l' v r' else concat l' r' 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 + (* call [p] in the expected left-to-right order *) + let (lt, lf) = partition p l in + let pv = p v in + let (rt, rf) = partition p r in + if pv then (join lt v rt, concat lf rf) else (concat lt rt, join lf v rf) diff --git a/stdlib/stream.ml b/stdlib/stream.ml index fc66acb3e9..55bf31d6ce 100644 --- a/stdlib/stream.ml +++ b/stdlib/stream.ml @@ -21,8 +21,8 @@ type 'a t = { count : int; data : 'a data } and 'a data = Sempty | Scons of 'a * 'a data - | Sapp of 'a data * 'a data - | Slazy of 'a data Lazy.t + | Sapp of 'a data * 'a t + | Slazy of 'a t Lazy.t | Sgen of 'a gen | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } @@ -42,26 +42,37 @@ let fill_buff b = b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 ;; -let rec get_data count d = match d with - (* Returns either Sempty or Scons(a, _) even when d is a generator - or a buffer. In those cases, the item a is seen as extracted from - the generator/buffer. - The count parameter is used for calling `Sgen-functions'. *) +let rec get_data s d = match d with + (* Only return a "forced stream", that is either Sempty or + Scons(a,_). If d is a generator or a buffer, the item a is seen as + extracted from the generator/buffer. + + Forcing also updates the "count" field of the delayed stream, + in the Sapp and Slazy cases (see slazy/lapp implementation below). *) Sempty | Scons (_, _) -> d - | Sapp (d1, d2) -> - begin match get_data count d1 with - Scons (a, d11) -> Scons (a, Sapp (d11, d2)) - | Sempty -> get_data count d2 + | Sapp (d1, s2) -> + begin match get_data s d1 with + Scons (a, d11) -> Scons (a, Sapp (d11, s2)) + | Sempty -> + set_count s s2.count; + get_data s s2.data | _ -> assert false end - | Sgen {curr = Some None; func = _ } -> Sempty - | Sgen ({curr = Some(Some a); func = f} as g) -> + | Sgen {curr = Some None; _ } -> Sempty + | Sgen ({curr = Some(Some a); _ } as g) -> g.curr <- None; Scons(a, d) - | Sgen g -> - begin match g.func count with + | Sgen ({curr = None; _} as g) -> + (* Warning: anyone using g thinks that an item has been read *) + begin match g.func s.count with None -> g.curr <- Some(None); Sempty - | Some a -> Scons(a, d) - (* Warning: anyone using g thinks that an item has been read *) + | Some a -> + (* One must not update g.curr here, because there Scons(a,d) + result of get_data, if the outer stream s was a Sapp, will + be used to update the outer stream to Scons(a,s): there is + already a memoization process at the outer layer. If g.curr + was updated here, the saved element would be produced twice, + once by the outer layer, once by Sgen/g.curr. *) + Scons(a, d) end | Sbuffio b -> if b.ind >= b.len then fill_buff b; @@ -69,7 +80,10 @@ let rec get_data count d = match d with let r = Obj.magic (String.unsafe_get b.buff b.ind) in (* Warning: anyone using g thinks that an item has been read *) b.ind <- succ b.ind; Scons(r, d) - | Slazy f -> get_data count (Lazy.force f) + | Slazy f -> + let s2 = Lazy.force f in + set_count s s2.count; + get_data s s2.data ;; let rec peek s = @@ -78,14 +92,20 @@ let rec peek s = Sempty -> None | Scons (a, _) -> Some a | Sapp (_, _) -> - begin match get_data s.count s.data with - Scons(a, _) as d -> set_data s d; Some a + begin match get_data s s.data with + | Scons(a, _) as d -> set_data s d; Some a | Sempty -> None | _ -> assert false end - | Slazy f -> set_data s (Lazy.force f); peek s - | Sgen {curr = Some a} -> a - | Sgen g -> let x = g.func s.count in g.curr <- Some x; x + | Slazy f -> + let s2 = Lazy.force f in + set_count s s2.count; + set_data s s2.data; + peek s + | Sgen {curr = Some a; _ } -> a + | Sgen ({curr = None; _ } as g) -> + let x = g.func s.count in + g.curr <- Some x; x | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then begin set_data s Sempty; None end @@ -157,18 +177,21 @@ let of_channel ic = (* Stream expressions builders *) -let iapp i s = {count = 0; data = Sapp (i.data, s.data)};; -let icons i s = {count = 0; data = Scons (i, s.data)};; -let ising i = {count = 0; data = Scons (i, Sempty)};; +(* In the slazy and lapp case, we can't statically predict the value + of the "count" field. We put a dummy 0 value, which will be updated + when the parameter stream is forced (see update code in [get_data] + and [peek]). *) -let lapp f s = - {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))} -;; -let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};; -let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};; +let ising i = {count = 0; data = Scons (i, Sempty)};; +let icons i s = {count = s.count - 1; data = Scons (i, s.data)};; +let iapp i s = {count = i.count; data = Sapp (i.data, s)};; let sempty = {count = 0; data = Sempty};; -let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};; +let slazy f = {count = 0; data = Slazy (lazy (f()))};; + +let lsing f = {count = 0; data = Slazy (lazy (ising (f())))};; +let lcons f s = {count = 0; data = Slazy (lazy (icons (f()) s))};; +let lapp f s = {count = 0; data = Slazy (lazy(iapp (f()) s))};; (* For debugging use *) @@ -188,11 +211,11 @@ and dump_data f = print_string ", "; dump_data f d; print_string ")" - | Sapp (d1, d2) -> + | Sapp (d1, s2) -> print_string "Sapp ("; dump_data f d1; print_string ", "; - dump_data f d2; + dump f s2; print_string ")" | Slazy _ -> print_string "Slazy" | Sgen _ -> print_string "Sgen" diff --git a/stdlib/stream.mli b/stdlib/stream.mli index 10cd976205..16e7117973 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -85,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.mli b/stdlib/string.mli index 7d7635f8b7..c248fab18a 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -223,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.mli b/stdlib/stringLabels.mli index f9be415cca..59b0eb7c28 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -175,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/testsuite/lib/Makefile b/testsuite/lib/Makefile index 904025ffdf..b6fc63c207 100644 --- a/testsuite/lib/Makefile +++ b/testsuite/lib/Makefile @@ -8,4 +8,7 @@ clean: defaultclean include ../makefiles/Makefile.common -compile-targets: testing.cmi testing.cmo $(if $(BYTECODE_ONLY),,testing.cmx) +compile-targets: testing.cmi testing.cmo + @if [ -z "$(BYTECODE_ONLY)" ]; then \ + $(MAKE) testing.cmx; \ + fi diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index 983f82c2fc..4cb3d8b1f7 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -7,15 +7,15 @@ include $(TOPDIR)/config/Makefile DIFF=diff -q BOOTDIR=$(TOPDIR)/boot OCAMLRUN=$(BOOTDIR)/ocamlrun$(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) +OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml -I $(TOPDIR)/stdlib +OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc $(NOJOIN) -I $(TOPDIR)/stdlib +OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt $(NOJOIN) -I $(TOPDIR)/stdlib +OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc +OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex +OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE) OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native -DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj$(EXE) +DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi` #COMPFLAGS= #FORTRAN_COMPILER= diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one index ca07bf16da..5c8e365e38 100644 --- a/testsuite/makefiles/Makefile.one +++ b/testsuite/makefiles/Makefile.one @@ -20,12 +20,15 @@ ADD_CFLAGS+=$(CUSTOM_FLAG) default: compile run -compile: $(ML_FILES) $(CMO_FILES) $(CMX_FILES) $(MAIN_MODULE).cmo $(MAIN_MODULE).cmx +compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo @for file in $(C_FILES); do \ $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \ done; + @rm -f program.byte program.byte.exe @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo @if [ -z "$(BYTECODE_ONLY)" ]; then \ + rm -f program.native program.native.exe; \ + $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \ $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \ fi diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 7d8ec7687c..af81182253 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -41,19 +41,20 @@ run-all: run-file: @printf " $(DESC)" - $(COMP) $(COMPFLAGS) $(FILE) -o program + @rm -f program program.exe + @$(COMP) $(COMPFLAGS) $(FILE) -o program @if [ -f `basename $(FILE) ml`runner ]; then \ sh `basename $(FILE) ml`runner; \ else \ ./program $(PROGRAM_ARGS) > `basename $(FILE) ml`result; \ - fi + fi || (echo " => failed" && exit 1) @if [ -f `basename $(FILE) ml`checker ]; then \ sh `basename $(FILE) ml`checker; \ else \ - $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null || (echo " => failed" && exit 1); \ - fi + $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null; \ + fi || (echo " => failed" && exit 1) promote: defaultpromote clean: defaultclean - @rm -f *.result ./program + @rm -f *.result ./program program.exe diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index 2161b856e4..8143873d65 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -1,4 +1,5 @@ BASEDIR=../.. + CC=$(NATIVECC) CFLAGS=$(NATIVECCCOMPOPTS) -g @@ -33,6 +34,7 @@ OTHEROBJS=\ $(TOPDIR)/typing/subst.cmo \ $(TOPDIR)/typing/predef.cmo \ $(TOPDIR)/typing/datarepr.cmo \ + $(TOPDIR)/typing/cmi_format.cmo \ $(TOPDIR)/typing/env.cmo \ $(TOPDIR)/typing/typedtree.cmo \ $(TOPDIR)/typing/ctype.cmo \ @@ -43,6 +45,7 @@ OTHEROBJS=\ $(TOPDIR)/typing/includemod.cmo \ $(TOPDIR)/typing/parmatch.cmo \ $(TOPDIR)/typing/typetexp.cmo \ + $(TOPDIR)/typing/cmt_format.cmo \ $(TOPDIR)/typing/stypes.cmo \ $(TOPDIR)/typing/typecore.cmo \ $(TOPDIR)/typing/typedecl.cmo \ @@ -139,11 +142,11 @@ clean: defaultclean @rm -f parsecmm.ml parsecmm.mli lexcmm.ml @rm -f $(CASES:=.s) +include $(BASEDIR)/makefiles/Makefile.common + power.o: power-$(SYSTEM).o @cp power-$(SYSTEM).o power.o promote: -include $(BASEDIR)/makefiles/Makefile.common - arch: $(ARCH).o diff --git a/testsuite/tests/asmcomp/i386.S b/testsuite/tests/asmcomp/i386.S index fc75b1f1f8..94e44c773f 100644 --- a/testsuite/tests/asmcomp/i386.S +++ b/testsuite/tests/asmcomp/i386.S @@ -15,7 +15,8 @@ /* Linux with ELF binaries does not prefix identifiers with _. Linux with a.out binaries, FreeBSD, and NextStep do. */ -#ifdef SYS_linux_elf +#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ + || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu) #define G(x) x #define FUNCTION_ALIGN 16 #else diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index 87db7a5fea..b0aeec879f 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -149,7 +149,8 @@ phrase: fundecl: LPAREN FUNCTION STRING LPAREN params RPAREN sequence RPAREN { List.iter (fun (id, ty) -> 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/sparc.S b/testsuite/tests/asmcomp/sparc.S index 5f83bf0f22..362c6f1355 100644 --- a/testsuite/tests/asmcomp/sparc.S +++ b/testsuite/tests/asmcomp/sparc.S @@ -12,7 +12,7 @@ /* $Id$ */ -#ifndef SYS_solaris +#if defined(SYS_solaris) || defined(SYS_elf) #define Call_gen_code _call_gen_code #define Caml_c_call _caml_c_call #else diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml index f843e70846..c457054dc7 100644 --- a/testsuite/tests/basic-io-2/io.ml +++ b/testsuite/tests/basic-io-2/io.ml @@ -11,8 +11,8 @@ let test msg funct f1 f2 = (* File copy with constant-sized chunks *) let copy_file sz infile ofile = - let ic = open_in infile in - let oc = open_out ofile in + let ic = open_in_bin infile in + let oc = open_out_bin ofile in let buffer = String.create sz in let rec copy () = let n = input ic buffer 0 sz in @@ -27,8 +27,8 @@ let copy_file sz infile ofile = (* File copy with random-sized chunks *) let copy_random sz infile ofile = - let ic = open_in infile in - let oc = open_out ofile in + let ic = open_in_bin infile in + let oc = open_out_bin ofile in let buffer = String.create sz in let rec copy () = let s = 1 + Random.int sz in @@ -44,8 +44,8 @@ let copy_random sz infile ofile = (* File copy line per line *) let copy_line infile ofile = - let ic = open_in infile in - let oc = open_out ofile in + let ic = open_in_bin infile in + let oc = open_out_bin ofile in try while true do output_string oc (input_line ic); output_char oc '\n' @@ -73,7 +73,7 @@ let copy_seek chunksize infile ofile = (* Create long lines of text *) let make_lines ofile = - let oc = open_out ofile in + let oc = open_out_bin ofile in for i = 1 to 256 do output_string oc (String.make (i*64) '.'); output_char oc '\n' done; diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml index 150d408898..af0e3a2f41 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 f063674d90..366e682c15 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/bigints.ml b/testsuite/tests/basic/bigints.ml index 0b101ffa1f..23e571c3fc 100644 --- a/testsuite/tests/basic/bigints.ml +++ b/testsuite/tests/basic/bigints.ml @@ -1,12 +1,25 @@ let _ = - print_int 1000000000; print_newline(); - print_int 10000000000; print_newline(); - print_int 100000000000; print_newline(); - print_int 1000000000000; print_newline(); - print_int 10000000000000; print_newline(); - print_int 100000000000000; print_newline(); - print_int 1000000000000000; print_newline(); - print_int 10000000000000000; print_newline(); - print_int 100000000000000000; print_newline(); - print_int 1000000000000000000; print_newline() - + match Sys.word_size with + | 32 -> + print_int (1 * 1000000000); print_newline(); + print_string "10000000000"; print_newline(); + print_string "100000000000"; print_newline(); + print_string "1000000000000"; print_newline(); + print_string "10000000000000"; print_newline(); + print_string "100000000000000"; print_newline(); + print_string "1000000000000000"; print_newline(); + print_string "10000000000000000"; print_newline(); + print_string "100000000000000000"; print_newline(); + print_string "1000000000000000000"; print_newline(); + | 64 -> + print_int (1 * 1000000000); print_newline(); + print_int (10 * 1000000000); print_newline(); + print_int (100 * 1000000000); print_newline(); + print_int (1000 * 1000000000); print_newline(); + print_int (10000 * 1000000000); print_newline(); + print_int (100000 * 1000000000); print_newline(); + print_int (1000000 * 1000000000); print_newline(); + print_int (10000000 * 1000000000); print_newline(); + print_int (100000000 * 1000000000); print_newline(); + print_int (1000000000 * 1000000000); print_newline() + | _ -> assert false diff --git a/testsuite/tests/lib-dynlink-bytecode/.ignore b/testsuite/tests/lib-dynlink-bytecode/.ignore index f22ec66027..789e3e0531 100644 --- a/testsuite/tests/lib-dynlink-bytecode/.ignore +++ b/testsuite/tests/lib-dynlink-bytecode/.ignore @@ -1,3 +1,5 @@ main static custom +custom.exe +marshal.data diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile index a510325bce..53e9f4692f 100644 --- a/testsuite/tests/lib-dynlink-bytecode/Makefile +++ b/testsuite/tests/lib-dynlink-bytecode/Makefile @@ -3,6 +3,7 @@ BASEDIR=../.. default: compile run compile: + @$(OCAMLC) -c registry.ml @for file in stub*.c; do \ $(OCAMLC) -c $$file; \ $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' | sed -e 's/\.c//'` `basename $$file c`o; \ @@ -12,9 +13,9 @@ compile: $(OCAMLMKLIB) -o `basename $$file .ml` `basename $$file ml`cmo; \ done @$(OCAMLC) -c main.ml - @$(OCAMLC) -o main dynlink.cma main.cmo - @$(OCAMLC) -o static -linkall plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun - @$(OCAMLC) -o custom -custom -linkall plug2.cma plug1.cma -I . + @$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo + @$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun + @$(OCAMLC) -o custom -custom -linkall registry.cmo plug2.cma plug1.cma -I . run: @printf " ... testing 'main'" @@ -35,6 +36,6 @@ run: promote: defaultpromote clean: defaultclean - @rm -f ./main ./static ./custom *.result + @rm -f ./main ./static ./custom *.result marshal.data include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-dynlink-bytecode/custom.reference b/testsuite/tests/lib-dynlink-bytecode/custom.reference index f7eeb3aeb3..c9d2b57582 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 bd980f1022..b79504287d 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 df46049bf3..577292f9aa 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 3246045170..d0490689fb 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 05f4fdaeda..350374e5b8 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 0000000000..e0f76423dd --- /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 32281bcf45..4faa129c34 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 18ddf3f136..dcae562a41 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 a118673543..4c6e6e3c21 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 c65b044e8e..b202772728 100644 --- a/testsuite/tests/lib-dynlink-csharp/Makefile +++ b/testsuite/tests/lib-dynlink-csharp/Makefile @@ -14,7 +14,7 @@ prepare: bytecode: @printf " ... testing 'bytecode':" - @if [ ! `which $(CSC) > /dev/null` ]; then \ + @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \ @@ -25,7 +25,7 @@ bytecode: bytecode-dll: @printf " ... testing 'bytecode-dll':" - @if [ ! `which $(CSC) > /dev/null` ]; then \ + @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \ @@ -37,7 +37,7 @@ bytecode-dll: native: @printf " ... testing 'native':" - @if [ ! `which $(CSC) > /dev/null` ]; then \ + @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \ @@ -48,7 +48,7 @@ native: native-dll: @printf " ... testing 'native-dll':" - @if [ ! `which $(CSC) > /dev/null` ]; then \ + @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c main.ml; \ diff --git a/testsuite/tests/lib-dynlink-native/.ignore b/testsuite/tests/lib-dynlink-native/.ignore index 4efb7cbc77..775ccb418f 100644 --- a/testsuite/tests/lib-dynlink-native/.ignore +++ b/testsuite/tests/lib-dynlink-native/.ignore @@ -1,3 +1,5 @@ mypack.pack.s result main +main.exe +marshal.data diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile index 902717e784..9aac1dbeca 100644 --- a/testsuite/tests/lib-dynlink-native/Makefile +++ b/testsuite/tests/lib-dynlink-native/Makefile @@ -16,7 +16,7 @@ compile: $(PLUGINS) main mylib.so run: @printf " ... testing 'main'" - @./main plugin_thread.so > result + @./main plugin.so plugin2.so plugin_thread.so > result @$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml index 843a1c78f7..304ee1f1f0 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 b21253fb2d..04b3aef7bb 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 501f1bfd32..f307b4f11c 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 daecace842..109c129d1a 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 c6adb139ea..e9e4ee45dd 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/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml index 84a71beb77..6bed1fd5e8 100644 --- a/testsuite/tests/lib-hashtbl/htbl.ml +++ b/testsuite/tests/lib-hashtbl/htbl.ml @@ -78,6 +78,7 @@ module HofM (M: Map.S) : Hashtbl.S with type key = M.key = type 'a t = (key, 'a) Hashtbl.t let create s = Hashtbl.create s let clear = Hashtbl.clear + let reset = Hashtbl.reset let copy = Hashtbl.copy let add = Hashtbl.add let remove = Hashtbl.remove @@ -189,4 +190,4 @@ let _ = TSP.test (pair_data d); printf "-- Lists of strings\n%!"; TSL.test (list_data d) - + diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml index 5af1e252e3..af59734b20 100644 --- a/testsuite/tests/lib-marshal/intext.ml +++ b/testsuite/tests/lib-marshal/intext.ml @@ -1,5 +1,7 @@ (* Test for output_value / input_value *) +let max_data_depth = 500000 + type t = A | B of int | C of float | D of string | E of char | F of t | G of t * t | H of int * t | I of t * float | J @@ -425,6 +427,103 @@ let rec check_big n x = | _ -> false end +(* Test for really deep data structures *) +let test_deep () = + (* Right-leaning *) + let rec loop acc i = + if i < max_data_depth + then loop (i :: acc) (i+1) + else acc in + let x = loop [] 0 in + let s = Marshal.to_string x [] in + test 425 (Marshal.from_string s 0 = x); + (* Left-leaning *) + let rec loop acc i = + if i < max_data_depth + then loop (G(acc, B i)) (i+1) + else acc in + let x = loop A 0 in + let s = Marshal.to_string x [] in + test 426 (Marshal.from_string s 0 = x) + +(* Test for objects *) +class foo = object (self : 'self) + val data1 = "foo" + val data2 = "bar" + val data3 = 42L + method test1 = data1 ^ data2 + method test2 = false + method test3 = self#test1 + method test4 = data3 +end + +class bar = object (self : 'self) + inherit foo as super + val! data2 = "test5" + val data4 = "test3" + val data5 = "test4" + method test1 = + data1 + ^ data2 + ^ data4 + ^ data5 + ^ Int64.to_string self#test4 +end + +class foobar = object (self : 'self) + inherit foo as super + inherit! bar +end + +(* Test for objects *) +let test_objects () = + let x = new foo in + let s = Marshal.to_string x [Marshal.Closures] in + let x = Marshal.from_string s 0 in + test 500 (x#test1 = "foobar"); + test 501 (x#test2 = false); + test 502 (x#test3 = "foobar"); + test 503 (x#test4 = 42L); + let x = new bar in + let s = Marshal.to_string x [Marshal.Closures] in + let x = Marshal.from_string s 0 in + test 504 (x#test1 = "footest5test3test442"); + test 505 (x#test2 = false); + test 506 (x#test3 = "footest5test3test442"); + test 507 (x#test4 = 42L); + let x0 = new foobar in + let s = Marshal.to_string x0 [Marshal.Closures] in + let x = Marshal.from_string s 0 in + test 508 (x#test1 = "footest5test3test442"); + test 509 (x#test2 = false); + test 510 (x#test3 = "footest5test3test442"); + test 511 (x#test4 = 42L); + test 512 (Oo.id x = Oo.id x0 + 1) (* PR#5610 *) + +(* Test for infix pointers *) +let test_infix () = + let t = true and + f = false in + let rec odd n = + if n = 0 + then f + else even (n-1) + and even n = + if n = 0 + then t + else odd (n-1) + in + let s = Marshal.to_string (odd, even) [Marshal.Closures] in + let (odd', even': (int -> bool) * (int -> bool)) = Marshal.from_string s 0 in + test 600 (odd' 41 = true); + test 601 (odd' 41 = odd 41); + test 602 (odd' 142 = false); + test 603 (odd' 142 = odd 142); + test 604 (even' 41 = false); + test 605 (even' 41 = even 41); + test 606 (even' 142 = true); + test 607 (even' 142 = even 142) + let main() = if Array.length Sys.argv <= 2 then begin test_out "intext.data"; test_in "intext.data"; @@ -433,7 +532,10 @@ let main() = test_string(); test_buffer(); test_size(); - test_block() + test_block(); + test_deep(); + test_objects(); + test_infix () end else if Sys.argv.(1) = "make" then begin let n = int_of_string Sys.argv.(2) in diff --git a/testsuite/tests/lib-marshal/intext.reference b/testsuite/tests/lib-marshal/intext.reference index 8def6706e7..6933ef3512 100644 --- a/testsuite/tests/lib-marshal/intext.reference +++ b/testsuite/tests/lib-marshal/intext.reference @@ -147,3 +147,26 @@ Test 421 passed. Test 422 passed. Test 423 passed. Test 424 passed. +Test 425 passed. +Test 426 passed. +Test 500 passed. +Test 501 passed. +Test 502 passed. +Test 503 passed. +Test 504 passed. +Test 505 passed. +Test 506 passed. +Test 507 passed. +Test 508 passed. +Test 509 passed. +Test 510 passed. +Test 511 passed. +Test 512 passed. +Test 600 passed. +Test 601 passed. +Test 602 passed. +Test 603 passed. +Test 604 passed. +Test 605 passed. +Test 606 passed. +Test 607 passed. diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile index 216b396301..7362fad9ca 100644 --- a/testsuite/tests/lib-scanf-2/Makefile +++ b/testsuite/tests/lib-scanf-2/Makefile @@ -2,10 +2,11 @@ BASEDIR=../.. default: compile run -compile: tscanf2_io.cmo tscanf2_io.cmx +compile: tscanf2_io.cmo @$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml @$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml @if [ -z "$(BYTECODE_ONLY)" ]; then \ + $(MAKE) tscanf2_io.cmx; \ $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \ $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \ fi diff --git a/testsuite/tests/lib-scanf/.ignore b/testsuite/tests/lib-scanf/.ignore new file mode 100644 index 0000000000..a940814e01 --- /dev/null +++ b/testsuite/tests/lib-scanf/.ignore @@ -0,0 +1 @@ +tscanf_data diff --git a/testsuite/tests/lib-scanf/tscanf_data b/testsuite/tests/lib-scanf/tscanf_data deleted file mode 100644 index e4ae5b689a..0000000000 --- a/testsuite/tests/lib-scanf/tscanf_data +++ /dev/null @@ -1 +0,0 @@ -"Objective" -> "Caml"; diff --git a/testsuite/tests/lib-stream/Makefile b/testsuite/tests/lib-stream/Makefile new file mode 100644 index 0000000000..65ecf125bd --- /dev/null +++ b/testsuite/tests/lib-stream/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +MODULES=testing +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-stream/count_concat_bug.ml b/testsuite/tests/lib-stream/count_concat_bug.ml new file mode 100644 index 0000000000..97ec6bce20 --- /dev/null +++ b/testsuite/tests/lib-stream/count_concat_bug.ml @@ -0,0 +1,57 @@ +let is_empty s = + try Stream.empty s; true with Stream.Failure -> false + +let test_icons = + let s = Stream.of_string "ab" in + let s = Stream.icons 'c' s in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_lcons = + let s = Stream.of_string "ab" in + let s = Stream.lcons (fun () -> 'c') s in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_iapp = + let s = Stream.of_string "ab" in + let s = Stream.iapp (Stream.of_list ['c']) s in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_lapp_right = + let s1 = Stream.of_list ['c'] in + let s2 = Stream.of_string "ab" in + let s = Stream.lapp (fun () -> s1) s2 in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_lapp_left = + let s1 = Stream.of_string "bc" in + let s2 = Stream.of_list ['a'] in + Testing.test (Stream.next s1 = 'b'); + let s = Stream.lapp (fun () -> s1) s2 in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (is_empty s); + () + +let test_slazy = + let s = Stream.of_string "ab" in + Testing.test (Stream.next s = 'a'); + let s = Stream.slazy (fun () -> s) in + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () diff --git a/testsuite/tests/lib-stream/count_concat_bug.reference b/testsuite/tests/lib-stream/count_concat_bug.reference new file mode 100644 index 0000000000..acdc75cac0 --- /dev/null +++ b/testsuite/tests/lib-stream/count_concat_bug.reference @@ -0,0 +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 +All tests succeeded. diff --git a/testsuite/tests/lib-threads/test1.checker b/testsuite/tests/lib-threads/test1.checker index cbfe7ce5d8..1d10457284 100644 --- a/testsuite/tests/lib-threads/test1.checker +++ b/testsuite/tests/lib-threads/test1.checker @@ -1 +1 @@ -sort test1.result | diff -q test1.reference - +LC_ALL=C sort test1.result | diff -q test1.reference - diff --git a/testsuite/tests/lib-threads/test4.checker b/testsuite/tests/lib-threads/test4.checker index ae27a0d570..b8661a9821 100644 --- a/testsuite/tests/lib-threads/test4.checker +++ b/testsuite/tests/lib-threads/test4.checker @@ -1 +1 @@ -sort -u test4.result | diff -q test4.reference - +LC_ALL=C sort -u test4.result | diff -q test4.reference - diff --git a/testsuite/tests/lib-threads/test5.checker b/testsuite/tests/lib-threads/test5.checker index 030fcc91e6..e991875718 100644 --- a/testsuite/tests/lib-threads/test5.checker +++ b/testsuite/tests/lib-threads/test5.checker @@ -1 +1 @@ -sort -u test5.result | diff -q test5.reference - +LC_ALL=C sort -u test5.result | diff -q test5.reference - diff --git a/testsuite/tests/lib-threads/test6.checker b/testsuite/tests/lib-threads/test6.checker index 40ab24f876..d2e9930af5 100644 --- a/testsuite/tests/lib-threads/test6.checker +++ b/testsuite/tests/lib-threads/test6.checker @@ -1 +1 @@ -sort -u test6.result | diff -q test6.reference - +LC_ALL=C sort -u test6.result | diff -q test6.reference - diff --git a/testsuite/tests/lib-threads/testA.checker b/testsuite/tests/lib-threads/testA.checker index 4c309401d0..9f5d00a879 100644 --- a/testsuite/tests/lib-threads/testA.checker +++ b/testsuite/tests/lib-threads/testA.checker @@ -1 +1 @@ -sort testA.result | diff -q testA.reference - +LC_ALL=C sort testA.result | diff -q testA.reference - diff --git a/testsuite/tests/lib-threads/testexit.checker b/testsuite/tests/lib-threads/testexit.checker index 5834e5d005..c1182d6f8e 100644 --- a/testsuite/tests/lib-threads/testexit.checker +++ b/testsuite/tests/lib-threads/testexit.checker @@ -1 +1 @@ -sort testexit.result | diff -q testexit.reference - +LC_ALL=C sort testexit.result | diff -q testexit.reference - diff --git a/testsuite/tests/lib-threads/testsignal2.runner b/testsuite/tests/lib-threads/testsignal2.runner index 0e368a9245..e215ec6ed4 100644 --- a/testsuite/tests/lib-threads/testsignal2.runner +++ b/testsuite/tests/lib-threads/testsignal2.runner @@ -3,4 +3,4 @@ pid=$! sleep 3 kill -INT $pid sleep 1 -kill -9 $pid || true +kill -9 $pid 2>&- || true diff --git a/testsuite/tests/regression/pr5233/Makefile b/testsuite/tests/regression/pr5233/Makefile new file mode 100644 index 0000000000..c7a1ed0e7c --- /dev/null +++ b/testsuite/tests/regression/pr5233/Makefile @@ -0,0 +1,4 @@ +MAIN_MODULE=pr5233 + +include ../../../makefiles/Makefile.one +include ../../../makefiles/Makefile.common diff --git a/testsuite/tests/regression/pr5233/pr5233.ml b/testsuite/tests/regression/pr5233/pr5233.ml new file mode 100644 index 0000000000..d0b5f76203 --- /dev/null +++ b/testsuite/tests/regression/pr5233/pr5233.ml @@ -0,0 +1,50 @@ +open Printf;; + +(* PR#5233: Create a dangling pointer and use it to access random parts + of the heap. *) + +(* The buggy weak array will end up in smuggle. *) +let smuggle = ref (Weak.create 1);; + +(* This will be the weak array (W). *) +let t = ref (Weak.create 1);; + +(* Set a finalisation function on W. *) +Gc.finalise (fun w -> smuggle := w) !t;; + +(* Free W and run its finalisation function. *) +t := Weak.create 1;; +Gc.full_major ();; + +(* smuggle now contains W, whose pointers are not erased, even + when the contents is deallocated. *) + +let size = 1_000_000;; + +let check o = + printf "checking..."; + match o with + | None -> printf " no value\n"; + | Some s -> + printf " value found / testing..."; + for i = 0 to size - 1 do + if s.[i] != ' ' then failwith "bad"; + done; + printf " ok\n"; +;; + +Weak.set !smuggle 0 (Some (String.make size ' '));; + +(* Check the data just to make sure. *) +check (Weak.get !smuggle 0);; + +(* Get a dangling pointer in W. *) +Gc.full_major ();; + +(* Fill the heap with other stuff. *) +let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu);; +let r = fill ((Gc.stat ()).Gc.heap_words / 3) [];; +Gc.minor ();; + +(* Now follow the dangling pointer and exhibit the problem. *) +check (Weak.get !smuggle 0);; diff --git a/testsuite/tests/regression/pr5233/pr5233.reference b/testsuite/tests/regression/pr5233/pr5233.reference new file mode 100644 index 0000000000..ef728f633a --- /dev/null +++ b/testsuite/tests/regression/pr5233/pr5233.reference @@ -0,0 +1,2 @@ +checking... value found / testing... ok +checking... no value diff --git a/testsuite/tests/tool-ocamldoc/Makefile b/testsuite/tests/tool-ocamldoc/Makefile index d112f568cd..2af4d34770 100644 --- a/testsuite/tests/tool-ocamldoc/Makefile +++ b/testsuite/tests/tool-ocamldoc/Makefile @@ -2,11 +2,14 @@ BASEDIR=../.. CUSTOM_MODULE=odoc_test ADD_COMPFLAGS=-I +ocamldoc +DIFF_OPT=--strip-trailing-cr +#DIFF_OPT=-b + run: $(CUSTOM_MODULE).cmo @for file in t*.ml; do \ printf " ... testing '$$file'"; \ $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \ - $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ + $(DIFF) $(DIFF_OPT) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ done; @$(OCAMLDOC) -hide-warnings -html t*.ml 2>&1 | grep -v test_types_display || true @$(OCAMLDOC) -hide-warnings -latex t*.ml 2>&1 | grep -v test_types_display || true diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml index 1339f10a59..b5cc55626b 100644 --- a/testsuite/tests/tool-ocamldoc/odoc_test.ml +++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml @@ -114,4 +114,4 @@ let _ = method generate = inst#generate end end in - Odoc_args.set_generator (Odoc_gen.Other (module My_generator : Odoc_gen.Base)) + Odoc_args.set_generator (Odoc_gen.Base (module My_generator : Odoc_gen.Base)) diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile index 9add15574f..5f42b70577 100644 --- a/testsuite/tests/typing-gadts/Makefile +++ b/testsuite/tests/typing-gadts/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-gadts/pr5689.ml b/testsuite/tests/typing-gadts/pr5689.ml new file mode 100644 index 0000000000..304f8e6cde --- /dev/null +++ b/testsuite/tests/typing-gadts/pr5689.ml @@ -0,0 +1,74 @@ +type inkind = [ `Link | `Nonlink ] + +type _ inline_t = + | Text: string -> [< inkind > `Nonlink ] inline_t + | Bold: 'a inline_t list -> 'a inline_t + | Link: string -> [< inkind > `Link ] inline_t + | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t +;; + +let uppercase seq = + let rec process: type a. a inline_t -> a inline_t = function + | Text txt -> Text (String.uppercase txt) + | Bold xs -> Bold (List.map process xs) + | Link lnk -> Link lnk + | Mref (lnk, xs) -> Mref (lnk, List.map process xs) + in List.map process seq +;; + +type ast_t = + | Ast_Text of string + | Ast_Bold of ast_t list + | Ast_Link of string + | Ast_Mref of string * ast_t list +;; + +let inlineseq_from_astseq seq = + let rec process_nonlink = function + | Ast_Text txt -> Text txt + | Ast_Bold xs -> Bold (List.map process_nonlink xs) + | _ -> assert false in + let rec process_any = function + | Ast_Text txt -> Text txt + | Ast_Bold xs -> Bold (List.map process_any xs) + | Ast_Link lnk -> Link lnk + | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs) + in List.map process_any seq +;; + +(* OK *) +type _ linkp = + | Nonlink : [ `Nonlink ] linkp + | Maylink : inkind linkp +;; +let inlineseq_from_astseq seq = + let rec process : type a. a linkp -> ast_t -> a inline_t = + fun allow_link ast -> + match (allow_link, ast) with + | (Maylink, Ast_Text txt) -> Text txt + | (Nonlink, Ast_Text txt) -> Text txt + | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) + | (Maylink, Ast_Link lnk) -> Link lnk + | (Nonlink, Ast_Link _) -> assert false + | (Maylink, Ast_Mref (lnk, xs)) -> + Mref (lnk, List.map (process Nonlink) xs) + | (Nonlink, Ast_Mref _) -> assert false + in List.map (process Maylink) seq +;; + +(* Bad *) +type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 +;; +let inlineseq_from_astseq seq = +let rec process : type a. a linkp2 -> ast_t -> a inline_t = + fun allow_link ast -> + match (allow_link, ast) with + | (Kind _, Ast_Text txt) -> Text txt + | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) + | (Kind Maylink, Ast_Link lnk) -> Link lnk + | (Kind Nonlink, Ast_Link _) -> assert false + | (Kind Maylink, Ast_Mref (lnk, xs)) -> + Mref (lnk, List.map (process (Kind Nonlink)) xs) + | (Kind Nonlink, Ast_Mref _) -> assert false + in List.map (process (Kind Maylink)) seq +;; diff --git a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference new file mode 100644 index 0000000000..f1e142aada --- /dev/null +++ b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference @@ -0,0 +1,28 @@ + +# type inkind = [ `Link | `Nonlink ] +type _ inline_t = + Text : string -> [< inkind > `Nonlink ] inline_t + | Bold : 'a inline_t list -> 'a inline_t + | Link : string -> [< inkind > `Link ] inline_t + | Mref : string * + [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t +# val uppercase : 'a inline_t list -> 'a inline_t list = <fun> +# type ast_t = + Ast_Text of string + | Ast_Bold of ast_t list + | Ast_Link of string + | Ast_Mref of string * ast_t list +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun> +# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun> +# type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 +# Characters 272-279: + | (Kind Maylink, Ast_Link lnk) -> Link lnk + ^^^^^^^ +Error: This pattern matches values of type inkind linkp + but a pattern was expected which matches values of type + ([< inkind ] as 'a) linkp + Type inkind = [ `Link | `Nonlink ] is not compatible with type + 'a = [< `Link | `Nonlink ] + Types for tag `Nonlink are incompatible +# diff --git a/testsuite/tests/typing-gadts/pr5689.ml.reference b/testsuite/tests/typing-gadts/pr5689.ml.reference new file mode 100644 index 0000000000..f1e142aada --- /dev/null +++ b/testsuite/tests/typing-gadts/pr5689.ml.reference @@ -0,0 +1,28 @@ + +# type inkind = [ `Link | `Nonlink ] +type _ inline_t = + Text : string -> [< inkind > `Nonlink ] inline_t + | Bold : 'a inline_t list -> 'a inline_t + | Link : string -> [< inkind > `Link ] inline_t + | Mref : string * + [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t +# val uppercase : 'a inline_t list -> 'a inline_t list = <fun> +# type ast_t = + Ast_Text of string + | Ast_Bold of ast_t list + | Ast_Link of string + | Ast_Mref of string * ast_t list +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun> +# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun> +# type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 +# Characters 272-279: + | (Kind Maylink, Ast_Link lnk) -> Link lnk + ^^^^^^^ +Error: This pattern matches values of type inkind linkp + but a pattern was expected which matches values of type + ([< inkind ] as 'a) linkp + Type inkind = [ `Link | `Nonlink ] is not compatible with type + 'a = [< `Link | `Nonlink ] + Types for tag `Nonlink are incompatible +# diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index 8d8bfc2e20..3fb5730aae 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -302,7 +302,7 @@ let f : type a. a j -> a = function type (_,_) eq = Eq : ('a,'a) eq ;; -let f : type a b. (a,b) eq -> (<m : a; ..> as 'a) -> (<m : b; ..> as 'a) = +let f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) = fun Eq o -> o ;; (* fail *) @@ -501,3 +501,14 @@ 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 index f692325f1d..3125e1e6a5 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -144,7 +144,7 @@ val f : 'a h -> 'a = <fun> val f : 'a j -> 'a = <fun> # type (_, _) eq = Eq : ('a, 'a) eq # Characters 5-91: - ....f : type a b. (a,b) eq -> (<m : a; ..> as 'a) -> (<m : b; ..> as 'a) = + ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) = fun Eq o -> o Error: The universal type variable 'b cannot be generalized: it is already bound to another variable. @@ -303,4 +303,7 @@ Error: This expression has type < bar : int; foo : int; .. > as 'a The type constructor ex#25 would escape its scope # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun> # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun> +# type 'a ty = Int : int -> int ty +# val f : 'a ty -> 'a = <fun> +# val g : 'a ty -> 'a = <fun> # diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index 8d05b4ffe8..36401d16f1 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -145,7 +145,7 @@ val f : 'a h -> 'a = <fun> val f : 'a j -> 'a = <fun> # type (_, _) eq = Eq : ('a, 'a) eq # Characters 5-91: - ....f : type a b. (a,b) eq -> (<m : a; ..> as 'a) -> (<m : b; ..> as 'a) = + ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) = fun Eq o -> o Error: The universal type variable 'b cannot be generalized: it is already bound to another variable. @@ -290,4 +290,7 @@ Error: This expression has type < bar : int; foo : int; .. > as 'a The type constructor ex#25 would escape its scope # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun> # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun> +# type 'a ty = Int : int -> int ty +# val f : 'a ty -> 'a = <fun> +# val g : 'a ty -> 'a = <fun> # diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile new file mode 100644 index 0000000000..5f42b70577 --- /dev/null +++ b/testsuite/tests/typing-misc/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common + diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml new file mode 100644 index 0000000000..5408ca2c1b --- /dev/null +++ b/testsuite/tests/typing-misc/constraints.ml @@ -0,0 +1,16 @@ +type 'a t = [`A of 'a t t] as 'a;; (* fails *) + +type 'a t = [`A of 'a t t];; (* fails *) + +type 'a t = [`A of 'a t t] constraint 'a = 'a t;; + +type 'a t = [`A of 'a t] constraint 'a = 'a t;; + +type 'a t = [`A of 'a] as 'a;; + +type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) + +type 'a t = 'a;; +let f (x : 'a t as 'a) = ();; (* fails *) + +let f (x : 'a t) (y : 'a) = x = y;; diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference new file mode 100644 index 0000000000..fe52044002 --- /dev/null +++ b/testsuite/tests/typing-misc/constraints.ml.reference @@ -0,0 +1,29 @@ + +# Characters 12-32: + type 'a t = [`A of 'a t t] as 'a;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^ +Error: Constraints are not satisfied in this type. + Type + [ `A of 'a ] t t as 'a + should be an instance of + ([ `A of 'b t t ] as 'b) t +# Characters 5-27: + type 'a t = [`A of 'a t t];; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of t, type 'a t t should be 'a t +# type 'a t = [ `A of 'a t t ] constraint 'a = 'a t +# type 'a t = [ `A of 'a t ] constraint 'a = 'a t +# type 'a t = 'a constraint 'a = [ `A of 'a ] +# Characters 47-52: + type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) + ^^^^^ +Error: The type abbreviation t is cyclic +# type 'a t = 'a +# Characters 11-21: + let f (x : 'a t as 'a) = ();; (* fails *) + ^^^^^^^^^^ +Error: This alias is bound to type 'a t = 'a + but is used as an instance of type 'a + The type variable 'a occurs inside 'a +# val f : 'a t -> 'a -> bool = <fun> +# diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml new file mode 100644 index 0000000000..36fa5ec782 --- /dev/null +++ b/testsuite/tests/typing-misc/records.ml @@ -0,0 +1,12 @@ +(* undefined labels *) +type t = {x:int;y:int};; +{x=3;z=2};; +fun {x=3;z=2} -> ();; + +(* mixed labels *) +{x=3; contents=2};; + +(* private types *) +type u = private {mutable u:int};; +{u=3};; +fun x -> x.u <- 3;; diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference new file mode 100644 index 0000000000..d69991a245 --- /dev/null +++ b/testsuite/tests/typing-misc/records.ml.reference @@ -0,0 +1,25 @@ + +# type t = { x : int; y : int; } +# Characters 5-6: + {x=3;z=2};; + ^ +Error: Unbound record field label z +# Characters 9-10: + fun {x=3;z=2} -> ();; + ^ +Error: Unbound record field label z +# Characters 26-34: + {x=3; contents=2};; + ^^^^^^^^ +Error: The record field label Pervasives.contents belongs to the type + 'a ref but is mixed here with labels of type t +# type u = private { mutable u : int; } +# Characters 0-5: + {u=3};; + ^^^^^ +Error: Cannot create values of the private type u +# Characters 11-12: + fun x -> x.u <- 3;; + ^ +Error: Cannot assign field u of the private type u +# diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index 82ea468f9c..afc170545f 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -1,5 +1,40 @@ +(* with module *) + module type S = sig type t and s = t end;; 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;; + +(* 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;; +module H = struct + include (Hashtbl : module type of Hashtbl with + type statistics := Hashtbl.statistics + and module type S := Hashtbl.S + and module Make := Hashtbl.Make + and module MakeSeeded := Hashtbl.MakeSeeded + and module type SeededS := Hashtbl.SeededS + and module type HashedType := Hashtbl.HashedType + and module type SeededHashedType := Hashtbl.SeededHashedType) +end;; +*) + +(* 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;; + +(* PR#4838 *) + +let id = let module M = struct end in fun x -> x;; + +(* PR#4511 *) + +let ko = let module M = struct end in fun _ -> ();; diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index 823cc1a840..c4ad0a05bc 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -1,6 +1,11 @@ -# module type S = sig type t and s = t end +# 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 +# val id : 'a -> 'a = <fun> +# val ko : 'a -> unit = <fun> # diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml index 212396cd19..ba3e64f011 100644 --- a/testsuite/tests/typing-objects/Exemples.ml +++ b/testsuite/tests/typing-objects/Exemples.ml @@ -216,7 +216,7 @@ end;; let c3 = new int_comparable3 15;; l#add (c3 :> 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 0000000000..d6f9d6df18 --- /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 = <obj> +# - : int = 7 +# - : unit = () +# - : int = 10 +# val q : < get_x : int; move : int -> unit > = <obj> +# - : 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 = <obj> +# - : int * string = (5, "red") +# val l : point list = [<obj>; <obj>] +# val get_x : < get_x : 'a; .. > -> 'a = <fun> +# val set_x : < set_x : 'a; .. > -> 'a = <fun> +# - : int list = [10; 5] +# Characters 7-96: + ......ref x_init = object + 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 = <obj> +val c' : < color : string; get_x : int; move : int -> unit > circle = <obj> +# 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 = <obj> +# - : color_point circle = <obj> +# 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 = <obj> +# 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 = <obj> +# (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 = <obj> +# - : int = 7 +# - : int = 10 +# - : int = 7 +# - : #functional_point -> functional_point = <fun> +# 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 = <obj> +# (3::10::[])- : unit = () +# val l2 : int lst = <obj> +# (4::11::[])- : unit = () +# val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun> +# val p1 : printable_color_point lst = <obj> +# ((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 = <obj> +# val c : int_comparable = <obj> +# - : unit = () +# val c2 : int_comparable2 = <obj> +# 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 = <obj> +# - : 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 = <fun> +# 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 = <fun> +# val l : int_comparable list = [<obj>; <obj>; <obj>] +# 5 2 4 +- : unit = () +# 2 4 5 +- : unit = () +# val l : int_comparable2 list = [<obj>; <obj>] +# 2 0 +- : unit = () +# 0 2 +- : unit = () +# val min : (#comparable as 'a) -> 'a -> 'a = <fun> +# - : 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 = <fun> +# 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 = <obj> +# - : 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 6be5b69483..128d1be70d 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 = <obj> # - : 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/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference new file mode 100644 index 0000000000..34a5071d78 --- /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 > += <fun> +# class ['a] c : unit -> object constraint 'a = int method f : int c end +and ['a] d : unit -> object constraint 'a = int method f : int c end +# Characters 238-275: + ........d () = object + 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 = <fun> +# * 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 = <f : 'a c; g : 'a d> + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of d, type int c should be 'a c +# type 'a c = < f : 'a c; g : 'a d > +and 'a d = < f : 'a c > +# 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 = <fun> +# - : t -> t u -> bool = <fun> +# 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 = <fun> +# - : ('a #M'.c as 'b) -> 'b = <fun> +# 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 = <obj> +# - : 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-54: + 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-92: + 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 = <obj> +# - : 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 = <fun> +# * * * * * * * * * * * * * * * * * * * * * 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 = <obj> +# module M : sig class c : unit -> object method m : c end end +# - : M.c = <obj> +# 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 = <fun> +# 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 +# - : < > -> < > = <fun> +# - : < .. > -> < > = <fun> +# 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 = <fun> +# Characters 18-26: + fun (x : 'a t) -> (x : 'a); ();; + ^^^^^^^^ +Warning 10: this expression should have type unit. +- : ('a t as 'a) t -> unit = <fun> +# class ['a] c : + unit -> + object constraint 'a = (< .. > as 'b) -> unit method m : '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 cbeaa61424..45130d58c3 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -168,9 +168,9 @@ Error: This expression has type bool but an expression was expected of type 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: +Characters 53-54: 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: @@ -179,9 +179,9 @@ Characters 81-84: 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: +Characters 91-92: val u = 3 - ^^^^^ + ^ Warning 13: the instance variable u is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class e : diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml b/testsuite/tests/typing-objects/pr5619_bad.ml new file mode 100644 index 0000000000..fbecc927c0 --- /dev/null +++ b/testsuite/tests/typing-objects/pr5619_bad.ml @@ -0,0 +1,29 @@ +class type foo_t = + object + method foo: string + end + +type 'a name = + Foo: foo_t name + | Int: int name +;; + +class foo = + object(self) + method foo = "foo" + method cast = + function + Foo -> (self :> <foo : string>) + | _ -> raise Exit + end +;; + +class foo: foo_t = + object(self) + method foo = "foo" + method cast: type a. a name -> a = + function + Foo -> (self :> foo_t) + | _ -> ((raise Exit) : a) + end +;; diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference new file mode 100644 index 0000000000..48777229ce --- /dev/null +++ b/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference @@ -0,0 +1,18 @@ + +# class type foo_t = object method foo : string end +type 'a name = Foo : foo_t name | Int : int name +# class foo : + object method cast : foo_t name -> < foo : string > method foo : string end +# Characters 22-184: + ..object(self) + method foo = "foo" + method cast: type a. a name -> a = + function + Foo -> (self :> foo_t) + | _ -> ((raise Exit) : a) + end +Error: The class type + object method cast : 'a name -> 'a method foo : string end + is not matched by the class type foo_t + The public method cast cannot be hidden +# diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml.reference b/testsuite/tests/typing-objects/pr5619_bad.ml.reference new file mode 100644 index 0000000000..48777229ce --- /dev/null +++ b/testsuite/tests/typing-objects/pr5619_bad.ml.reference @@ -0,0 +1,18 @@ + +# class type foo_t = object method foo : string end +type 'a name = Foo : foo_t name | Int : int name +# class foo : + object method cast : foo_t name -> < foo : string > method foo : string end +# Characters 22-184: + ..object(self) + method foo = "foo" + method cast: type a. a name -> a = + function + Foo -> (self :> foo_t) + | _ -> ((raise Exit) : a) + end +Error: The class type + object method cast : 'a name -> 'a method foo : string end + is not matched by the class type foo_t + The public method cast cannot be hidden +# diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index 17e643ad15..906d84f533 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -633,8 +633,8 @@ 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 @@ -643,3 +643,15 @@ module Polux = struct class alias = object method alias : 'a . 'a t -> 'a = ident end let f (x : <m : 'a. 'a t>) = (x : <m : 'a. 'a>) 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);; + +(* PR#5224 *) + +type 'x t = < f : 'y. 'y t >;; diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index b953491622..f7dc11e264 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -300,7 +300,7 @@ and 'a v = 'a u t constraint 'a = int Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g -and 'a v = 'a u t constraint 'a = int +and 'a v = 'a u t constraint 'a = g # Characters 38-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; ^^^^^^^^^^^^^^^^^^^^ @@ -620,9 +620,9 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun> val l : t = {f = <lazy>} # type t = { f : 'a. 'a -> unit; } # - : t = {f = <fun>} -# 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 : @@ -632,4 +632,11 @@ Error: This field value has type unit -> unit which is less general than 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. +# Characters 20-44: + type 'x t = < f : 'y. 'y t >;; + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of t, type 'y t should be 'x t # diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index f916c5b4b1..0f0448e674 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -283,7 +283,7 @@ and 'a v = 'a u t constraint 'a = int Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g -and 'a v = 'a u t constraint 'a = int +and 'a v = 'a u t constraint 'a = g # Characters 38-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; ^^^^^^^^^^^^^^^^^^^^ @@ -441,12 +441,7 @@ Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) > = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: - Modules do not match: - sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end - is not included in - sig - val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit - end + ... Values do not match: val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit is not included in @@ -583,9 +578,9 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun> val l : t = {f = <lazy>} # type t = { f : 'a. 'a -> unit; } # - : t = {f = <fun>} -# 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 : @@ -595,4 +590,11 @@ Error: This field value has type unit -> unit which is less general than 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. +# Characters 20-44: + type 'x t = < f : 'y. 'y t >;; + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of t, type 'y t should be 'x t # diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml index 4cb22fa2db..6759f63ab2 100644 --- a/testsuite/tests/typing-sigsubst/sigsubst.ml +++ b/testsuite/tests/typing-sigsubst/sigsubst.ml @@ -9,7 +9,7 @@ end;; module type PrintableComparable = sig include Printable include Comparable with type t = t -end;; +end;; (* Fails *) module type PrintableComparable = sig type t include Printable with type t := t @@ -35,3 +35,6 @@ 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;; + + +module type S = sig type 'a t end with type 'a t := unit;; (* Fails *) diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference index 3adcb82a98..5a160347b4 100644 --- a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference +++ b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference @@ -33,4 +33,8 @@ Error: Multiple definition of the type name t. sig module T : sig type exp type arg end val f : T.exp -> T.arg end # module M : sig type exp = string type arg = int end # module type S' = sig val f : M.exp -> M.arg end +# Characters 41-58: + module type S = sig type 'a t end with type 'a t := unit;; (* Fails *) + ^^^^^^^^^^^^^^^^^ +Error: Only type constructors with identical parameters can be substituted. # diff --git a/testsuite/tests/typing-typeparam/Makefile b/testsuite/tests/typing-typeparam/Makefile index 748631f909..5f42b70577 100644 --- a/testsuite/tests/typing-typeparam/Makefile +++ b/testsuite/tests/typing-typeparam/Makefile @@ -1,7 +1,4 @@ -#MODULES= BASEDIR=../.. -MAIN_MODULE=newtype -ADD_COMPFLAGS=-w a - -include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common + diff --git a/testsuite/tests/typing-typeparam/newtype.ml b/testsuite/tests/typing-typeparam/newtype.ml index 24eb2fcfc0..abe587634c 100644 --- a/testsuite/tests/typing-typeparam/newtype.ml +++ b/testsuite/tests/typing-typeparam/newtype.ml @@ -1,6 +1,7 @@ let property (type t) () = let module M = struct exception E of t end in (fun x -> M.E x), (function M.E x -> Some x | _ -> None) +;; let () = let (int_inj, int_proj) = property () in @@ -13,15 +14,19 @@ let () = Printf.printf "%b\n%!" (int_proj s = None); Printf.printf "%b\n%!" (string_proj i = None); Printf.printf "%b\n%!" (string_proj s = None) - - - +;; let sort_uniq (type s) cmp l = let module S = Set.Make(struct type t = s let compare = cmp end) in S.elements (List.fold_right S.add l S.empty) +;; let () = print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ])) +;; - +let f x (type a) (y : a) = (x = y);; (* Fails *) +class ['a] c = object (self) + method m : 'a -> 'a = fun x -> x + method n : 'a -> 'a = fun (type g) (x:g) -> self#m x +end;; (* Fails *) diff --git a/testsuite/tests/typing-typeparam/newtype.ml.reference b/testsuite/tests/typing-typeparam/newtype.ml.reference new file mode 100644 index 0000000000..c28cf53a6e --- /dev/null +++ b/testsuite/tests/typing-typeparam/newtype.ml.reference @@ -0,0 +1,19 @@ + +# val property : unit -> ('a -> exn) * (exn -> 'a option) = <fun> +# false +true +true +false +# val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = <fun> +# abc,xyz +# Characters 33-34: + let f x (type a) (y : a) = (x = y);; (* Fails *) + ^ +Error: This expression has type a but an expression was expected of type a + The type constructor a would escape its scope +# Characters 117-118: + method n : 'a -> 'a = fun (type g) (x:g) -> self#m x + ^ +Error: This expression has type g but an expression was expected of type g + The type constructor g would escape its scope +# diff --git a/testsuite/tests/typing-typeparam/newtype.reference b/testsuite/tests/typing-typeparam/newtype.reference deleted file mode 100644 index ab102d7d6b..0000000000 --- a/testsuite/tests/typing-typeparam/newtype.reference +++ /dev/null @@ -1,5 +0,0 @@ -false -true -true -false -abc,xyz diff --git a/tools/.depend b/tools/.depend index f23fdffb21..e6e2f096e2 100644 --- a/tools/.depend +++ b/tools/.depend @@ -1,15 +1,30 @@ depend.cmi : ../parsing/parsetree.cmi profiling.cmi : +typedtreeIter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi +untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \ + ../parsing/parsetree.cmi ../parsing/longident.cmi addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \ ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi +cmt2annot.cmo : untypeast.cmi typedtreeIter.cmi ../typing/typedtree.cmi \ + ../typing/stypes.cmi pprintast.cmo ../typing/path.cmi \ + ../typing/oprint.cmi ../parsing/location.cmi ../typing/ident.cmi \ + ../typing/env.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \ + ../typing/annot.cmi +cmt2annot.cmx : untypeast.cmx typedtreeIter.cmx ../typing/typedtree.cmx \ + ../typing/stypes.cmx pprintast.cmx ../typing/path.cmx \ + ../typing/oprint.cmx ../parsing/location.cmx ../typing/ident.cmx \ + ../typing/env.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \ + ../typing/annot.cmi cvt_emit.cmo : cvt_emit.cmx : depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \ - ../parsing/longident.cmi ../parsing/location.cmi depend.cmi + ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi \ + depend.cmi depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \ - ../parsing/longident.cmx ../parsing/location.cmx depend.cmi + ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi \ + depend.cmi dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \ ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \ ../bytecomp/instruct.cmi ../typing/ident.cmi ../bytecomp/emitcode.cmi \ @@ -24,10 +39,12 @@ 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 + ../typing/cmi_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 + ../typing/cmi_format.cmx ../asmcomp/clambda.cmx \ + ../bytecomp/bytesections.cmx ocaml299to3.cmo : ocaml299to3.cmx : ocamlcp.cmo : ../driver/main_args.cmi @@ -44,6 +61,8 @@ 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 \ @@ -54,9 +73,25 @@ ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ ../utils/clflags.cmx opnames.cmo : opnames.cmx : +pprintast.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \ + ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi +pprintast.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \ + ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi profiling.cmo : profiling.cmi profiling.cmx : profiling.cmi +read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi +read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx scrapelabels.cmo : scrapelabels.cmx : +typedtreeIter.cmo : ../typing/typedtree.cmi ../utils/misc.cmi \ + ../parsing/asttypes.cmi typedtreeIter.cmi +typedtreeIter.cmx : ../typing/typedtree.cmx ../utils/misc.cmx \ + ../parsing/asttypes.cmi typedtreeIter.cmi +untypeast.cmo : ../typing/typedtree.cmi ../typing/path.cmi \ + ../parsing/parsetree.cmi ../utils/misc.cmi ../parsing/longident.cmi \ + ../typing/ident.cmi ../parsing/asttypes.cmi untypeast.cmi +untypeast.cmx : ../typing/typedtree.cmx ../typing/path.cmx \ + ../parsing/parsetree.cmi ../utils/misc.cmx ../parsing/longident.cmx \ + ../typing/ident.cmx ../parsing/asttypes.cmi untypeast.cmi diff --git a/tools/.ignore b/tools/.ignore index cf3c69515d..1ddcc25601 100644 --- a/tools/.ignore +++ b/tools/.ignore @@ -10,6 +10,7 @@ cvt_emit cvt_emit.bak cvt_emit.ml ocamlcp +ocamloptp ocamlmktop primreq ocamldumpobj @@ -23,3 +24,6 @@ scrapelabels addlabels myocamlbuild_config.ml objinfo_helper +objinfo_helper.exe +read_cmt +read_cmt.bak diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 15062983bb..28709777df 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -20,10 +20,11 @@ CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib $(NOJOIN) CAMLLEX=$(CAMLRUN) ../boot/ocamllex INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ -I ../driver -COMPFLAGS= -warn-error A $(INCLUDES) +COMPFLAGS= -annot -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) -all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib dumpobj objinfo +all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \ + objinfo read_cmt .PHONY: all @@ -68,13 +69,23 @@ 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)/jocamlprof$(EXE) cp ocamlcp $(BINDIR)/jocamlcp$(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 (OCaml + C) @@ -183,6 +194,47 @@ clean:: beforedepend:: cvt_emit.ml + +# Reading cmt files + +READ_CMT= \ + ../utils/misc.cmo \ + ../utils/warnings.cmo \ + ../utils/tbl.cmo \ + ../utils/consistbl.cmo \ + ../utils/config.cmo \ + ../utils/clflags.cmo \ + ../parsing/location.cmo \ + ../parsing/longident.cmo \ + ../parsing/lexer.cmo \ + ../typing/ident.cmo \ + ../typing/path.cmo \ + ../typing/types.cmo \ + ../typing/typedtree.cmo \ + ../typing/btype.cmo \ + ../typing/subst.cmo \ + ../typing/predef.cmo \ + ../typing/datarepr.cmo \ + ../typing/cmi_format.cmo \ + ../typing/env.cmo \ + ../typing/ctype.cmo \ + ../typing/oprint.cmo \ + ../typing/primitive.cmo \ + ../typing/printtyp.cmo \ + ../typing/cmt_format.cmo \ + ../typing/stypes.cmo \ + \ + pprintast.cmo untypeast.cmo typedtreeIter.cmo \ + cmt2annot.cmo read_cmt.cmo + +read_cmt: $(READ_CMT) + $(CAMLC) $(LINKFLAGS) -o read_cmt $(READ_CMT) + +clean:: + rm -f read_cmt + +beforedepend:: + # The bytecode disassembler DUMPOBJ=opnames.cmo dumpobj.cmo @@ -218,7 +270,9 @@ objinfo_helper$(EXE): objinfo_helper.c ../config/s.h $(BYTECC) -o objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \ objinfo_helper.c $(LIBBFD_LINK) -OBJINFO=../utils/misc.cmo ../utils/config.cmo ../bytecomp/bytesections.cmo \ +OBJINFO=../utils/misc.cmo ../utils/config.cmo \ + ../utils/warnings.cmo ../parsing/location.cmo \ + ../typing/cmi_format.cmo ../bytecomp/bytesections.cmo \ objinfo.cmo objinfo: objinfo_helper$(EXE) $(OBJINFO) diff --git a/tools/addlabels.ml b/tools/addlabels.ml index a1c6a74ae3..91ce7930d8 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -49,11 +49,11 @@ let rec labels_of_cty cty = Pcty_fun (lab, _, rem) -> let (labs, meths) = labels_of_cty rem in (lab :: labs, meths) - | Pcty_signature (_, fields) -> + | Pcty_signature { pcsig_fields = fields } -> ([], List.fold_left fields ~init:[] ~f: begin fun meths -> function - Pctf_meth (s, _, sty, _) -> (s, labels_of_sty sty)::meths + { pctf_desc = Pctf_meth (s, _, sty) } -> (s, labels_of_sty sty)::meths | _ -> meths end) | _ -> @@ -61,9 +61,9 @@ let rec labels_of_cty cty = let rec pattern_vars pat = match pat.ppat_desc with - Ppat_var s -> [s] + Ppat_var s -> [s.txt] | Ppat_alias (pat, s) -> - s :: pattern_vars pat + s.txt :: pattern_vars pat | Ppat_tuple l | Ppat_array l -> List.concat (List.map pattern_vars l) @@ -124,7 +124,7 @@ let rec insert_labels ~labels ~text expr = let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point start_c ~text in match pattern_name pat with - | Some name when l = name -> add_insertion pos "~" + | Some name when l = name.txt -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; insert_labels ~labels ~text rem @@ -164,7 +164,7 @@ let rec insert_labels_class ~labels ~text expr = let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point start_c ~text in match pattern_name pat with - | Some name when l = name -> add_insertion pos "~" + | Some name when l = name.txt -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; insert_labels_class ~labels ~text rem @@ -192,7 +192,7 @@ let rec insert_labels_app ~labels ~text args = let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point pos0 ~text in match arg.pexp_desc with - | Pexp_ident(Longident.Lident name) when l = name && pos = pos0 -> + | Pexp_ident({ txt = Longident.Lident name }) when l = name && pos = pos0 -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; @@ -218,7 +218,7 @@ let rec add_labels_expr ~text ~values ~classes expr = let add_labels_rec ?(values=values) expr = add_labels_expr ~text ~values ~classes expr in match expr.pexp_desc with - Pexp_apply ({pexp_desc=Pexp_ident(Longident.Lident s)}, args) -> + Pexp_apply ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })}, args) -> begin try let labels = SMap.find s values in insert_labels_app ~labels ~text args @@ -226,14 +226,14 @@ let rec add_labels_expr ~text ~values ~classes expr = end; List.iter args ~f:(fun (_,e) -> add_labels_rec e) | Pexp_apply ({pexp_desc=Pexp_send - ({pexp_desc=Pexp_ident(Longident.Lident s)},meth)}, args) -> + ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},meth)}, args) -> begin try if SMap.find s values = ["<object>"] then let labels = SMap.find (s ^ "#" ^ meth) values in insert_labels_app ~labels ~text args with Not_found -> () end - | Pexp_apply ({pexp_desc=Pexp_new (Longident.Lident s)}, args) -> + | Pexp_apply ({pexp_desc=Pexp_new ({ txt = Longident.Lident s })}, args) -> begin try let labels = SMap.find s classes in insert_labels_app ~labels ~text args @@ -288,7 +288,7 @@ let rec add_labels_expr ~text ~values ~classes expr = add_labels_rec e1; add_labels_rec e2; add_labels_rec e3 | Pexp_for (s, e1, e2, _, e3) -> add_labels_rec e1; add_labels_rec e2; - add_labels_rec e3 ~values:(SMap.removes [s] values) + add_labels_rec e3 ~values:(SMap.removes [s.txt] values) | Pexp_override lst -> List.iter lst ~f:(fun (_,e) -> add_labels_rec e) | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _ @@ -302,23 +302,23 @@ let rec add_labels_expr ~text ~values ~classes expr = let rec add_labels_class ~text ~classes ~values ~methods cl = match cl.pcl_desc with Pcl_constr _ -> () - | Pcl_structure (p, l) -> + | Pcl_structure { pcstr_pat = p; pcstr_fields = l } -> let values = SMap.removes (pattern_vars p) values in let values = match pattern_name p with None -> values | Some s -> List.fold_left methods - ~init:(SMap.add s ["<object>"] values) - ~f:(fun m (k,l) -> SMap.add (s^"#"^k) l m) + ~init:(SMap.add s.txt ["<object>"] values) + ~f:(fun m (k,l) -> SMap.add (s.txt^"#"^k) l m) in ignore (List.fold_left l ~init:values ~f: - begin fun values -> function - | Pcf_val (s, _, _, e, _) -> + begin fun values -> function e -> match e.pcf_desc with + | Pcf_val (s, _, _, e) -> add_labels_expr ~text ~classes ~values e; - SMap.removes [s] values - | Pcf_meth (s, _, _, e, _) -> + SMap.removes [s.txt] values + | Pcf_meth (s, _, _, e) -> begin try - let labels = List.assoc s methods in + let labels = List.assoc s.txt methods in insert_labels ~labels ~text e with Not_found -> () end; @@ -327,7 +327,7 @@ let rec add_labels_class ~text ~classes ~values ~methods cl = | Pcf_init e -> add_labels_expr ~text ~classes ~values e; values - | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> values + | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> values end) | Pcl_fun (_, opt, pat, cl) -> begin match opt with None -> () @@ -357,12 +357,12 @@ let add_labels ~intf ~impl ~file = begin fun (values, classes as acc) item -> match item.psig_desc with Psig_value (name, {pval_type = sty}) -> - (SMap.add name (labels_of_sty sty) values, classes) + (SMap.add name.txt (labels_of_sty sty) values, classes) | Psig_class l -> (values, List.fold_left l ~init:classes ~f: begin fun classes {pci_name=name; pci_expr=cty} -> - SMap.add name (labels_of_cty cty) classes + SMap.add name.txt (labels_of_cty cty) classes end) | _ -> acc @@ -380,7 +380,7 @@ let add_labels ~intf ~impl ~file = begin match pattern_name pat with | Some s -> begin try - let labels = SMap.find s values in + let labels = SMap.find s.txt values in insert_labels ~labels ~text expr; if !norec then () else let values = @@ -397,17 +397,17 @@ let add_labels ~intf ~impl ~file = (SMap.removes names values, classes) | Pstr_primitive (s, {pval_type=sty}) -> begin try - let labels = SMap.find s values in + let labels = SMap.find s.txt values in insert_labels_type ~labels ~text sty; - (SMap.removes [s] values, classes) + (SMap.removes [s.txt] values, classes) with Not_found -> acc end | Pstr_class l -> - let names = List.map l ~f:(fun pci -> pci.pci_name) in + let names = List.map l ~f:(fun pci -> pci.pci_name.txt) in List.iter l ~f: begin fun {pci_name=name; pci_expr=expr} -> try - let (labels, methods) = SMap.find name classes in + let (labels, methods) = SMap.find name.txt classes in insert_labels_class ~labels ~text expr; if !norec then () else let classes = diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml new file mode 100644 index 0000000000..917ab2ffb1 --- /dev/null +++ b/tools/cmt2annot.ml @@ -0,0 +1,290 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* +Generate .annot file from a .types files. +*) + +open Typedtree +open TypedtreeIter + +let pattern_scopes = ref [] + +let push_None () = + pattern_scopes := None :: !pattern_scopes +let push_Some annot = + pattern_scopes := (Some annot) :: !pattern_scopes +let pop_scope () = + match !pattern_scopes with + [] -> assert false + | _ :: scopes -> pattern_scopes := scopes + +module ForIterator = struct + open Asttypes + + include DefaultIteratorArgument + + let structure_begin_scopes = ref [] + let structure_end_scopes = ref [] + + let rec find_last list = + match list with + [] -> assert false + | [x] -> x + | _ :: tail -> find_last tail + + let enter_structure str = + match str.str_items with + [] -> () + | _ -> + let loc = + match !structure_end_scopes with + [] -> Location.none + | _ -> + let s = find_last str.str_items in + s.str_loc + in + structure_end_scopes := loc :: !structure_end_scopes; + + let rec iter list = + match list with + [] -> assert false + | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] -> + structure_begin_scopes := loc.Location.loc_end + :: !structure_begin_scopes + | [ _ ] -> () + | item :: tail -> + iter tail; + match item, tail with + { str_desc = Tstr_value (Nonrecursive,_) }, + { str_loc = loc } :: _ -> + structure_begin_scopes := loc.Location.loc_start + :: !structure_begin_scopes + | _ -> () + in + iter str.str_items + + let leave_structure str = + match str.str_items with + [] -> () + | _ -> + match !structure_end_scopes with + [] -> assert false + | _ :: scopes -> structure_end_scopes := scopes + + let enter_class_expr node = + Stypes.record (Stypes.Ti_class node) + let enter_module_expr node = + Stypes.record (Stypes.Ti_mod node) + + let add_variable pat id = + match !pattern_scopes with + | [] -> assert false + | None :: _ -> () + | (Some s) :: _ -> + Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s)) + + let enter_pattern pat = + match pat.pat_desc with + | Tpat_var (id, _) + | Tpat_alias (_, id,_) + -> add_variable pat id + | Tpat_any -> () + | Tpat_constant _ + | Tpat_tuple _ + | Tpat_construct _ + | Tpat_lazy _ + | Tpat_or _ + | Tpat_array _ + | Tpat_record _ + | Tpat_variant _ + -> () + + let leave_pattern pat = + Stypes.record (Stypes.Ti_pat pat) + + let rec name_of_path = function + | Path.Pident id -> Ident.name id + | Path.Pdot(p, s, pos) -> + if Oprint.parenthesized_ident s then + name_of_path p ^ ".( " ^ s ^ " )" + else + name_of_path p ^ "." ^ s + | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")" + + let enter_expression exp = + match exp.exp_desc with + Texp_ident (path, _, _) -> + let full_name = name_of_path path in + begin + try + let annot = Env.find_annot path exp.exp_env in + Stypes.record + (Stypes.An_ident (exp.exp_loc, full_name , annot)) + with Not_found -> + Stypes.record + (Stypes.An_ident (exp.exp_loc, full_name , Annot.Iref_external)) + end + + | Texp_let (rec_flag, _, body) -> + begin + match rec_flag with + | Recursive -> push_Some (Annot.Idef exp.exp_loc) + | Nonrecursive -> push_Some (Annot.Idef body.exp_loc) + | Default -> push_None () + end + | Texp_function _ -> push_None () + | Texp_match _ -> push_None () + | Texp_try _ -> push_None () + | _ -> () + + let leave_expression exp = + if not exp.exp_loc.Location.loc_ghost then + Stypes.record (Stypes.Ti_expr exp); + match exp.exp_desc with + | Texp_let _ + | Texp_function _ + | Texp_match _ + | Texp_try _ + -> pop_scope () + | _ -> () + + let enter_binding pat exp = + let scope = + match !pattern_scopes with + | [] -> assert false + | None :: _ -> Some (Annot.Idef exp.exp_loc) + | scope :: _ -> scope + in + pattern_scopes := scope :: !pattern_scopes + + let leave_binding _ _ = + pop_scope () + + let enter_class_expr exp = + match exp.cl_desc with + | Tcl_fun _ -> push_None () + | Tcl_let _ -> push_None () + | _ -> () + + let leave_class_expr exp = + match exp.cl_desc with + | Tcl_fun _ + | Tcl_let _ -> pop_scope () + | _ -> () + + let enter_class_structure _ = + push_None () + + let leave_class_structure _ = + pop_scope () + +(* + let enter_class_field cf = + match cf.cf_desc with + Tcf_let _ -> push_None () + | _ -> () + + let leave_class_field cf = + match cf.cf_desc with + Tcf_let _ -> pop_scope () + | _ -> () +*) + + let enter_structure_item s = + Stypes.record_phrase s.str_loc; + match s.str_desc with + Tstr_value (rec_flag, _) -> + begin + let loc = s.str_loc in + let scope = match !structure_end_scopes with + [] -> assert false + | scope :: _ -> scope + in + match rec_flag with + | Recursive -> push_Some + (Annot.Idef { scope with + Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> +(* TODO: do it lazily, when we start the next element ! *) +(* + let start = match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start +in *) + let start = + match !structure_begin_scopes with + [] -> assert false + | loc :: tail -> + structure_begin_scopes := tail; + loc + in + push_Some (Annot.Idef {scope with Location.loc_start = start}) + | Default -> push_None () + end + | _ -> () + + let leave_structure_item s = + match s.str_desc with + Tstr_value _ -> pop_scope () + | _ -> () + + + end + +module Iterator = MakeIterator(ForIterator) + +let gen_annot target_filename filename cmt = + match cmt.Cmt_format.cmt_annots with + Cmt_format.Implementation typedtree -> + Iterator.iter_structure typedtree; + let target_filename = match target_filename with + None -> Some (filename ^ ".annot") + | Some "-" -> None + | Some filename -> target_filename + in + Stypes.dump target_filename + | Cmt_format.Interface _ -> + Printf.fprintf stderr "Cannot generate annotations for interface file\n%!"; + exit 2 + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + + + +let gen_ml target_filename filename cmt = + let (printer, ext) = + match cmt.Cmt_format.cmt_annots with + | Cmt_format.Implementation typedtree -> + (fun ppf -> Pprintast.print_structure ppf (Untypeast.untype_structure typedtree)), ".ml" + | Cmt_format.Interface typedtree -> + (fun ppf -> Pprintast.print_signature ppf (Untypeast.untype_signature typedtree)), ".mli" + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + in + let target_filename = match target_filename with + None -> Some (filename ^ ext) + | Some "-" -> None + | Some filename -> target_filename + in + let oc = match target_filename with + None -> None + | Some filename -> Some (open_out filename) in + let ppf = match oc with + None -> Format.std_formatter + | Some oc -> Format.formatter_of_out_channel oc in + printer ppf; + Format.pp_print_flush ppf (); + match oc with + None -> flush stdout + | Some oc -> close_out oc diff --git a/tools/depend.ml b/tools/depend.ml index acbe833ebb..fc2451bca0 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -12,6 +12,7 @@ (* $Id$ *) +open Asttypes open Format open Location open Longident @@ -21,6 +22,8 @@ module StringSet = Set.Make(struct type t = string let compare = compare end) (* Collect free module identifiers in the a.s.t. *) +let fst3 (x, _, _) = x + let free_structure_names = ref StringSet.empty let rec addmodule bv lid = @@ -32,10 +35,12 @@ let rec addmodule bv lid = | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2 let add bv lid = - match lid with + match lid.txt with Ldot(l, s) -> addmodule bv l | _ -> () +let addmodule bv lid = addmodule bv lid.txt + let rec add_type bv ty = match ty.ptyp_desc with Ptyp_any -> () @@ -56,7 +61,7 @@ let rec add_type bv ty = and add_package_type bv (lid, l) = add bv lid; - List.iter (add_type bv) (List.map snd l) + List.iter (add_type bv) (List.map (fun (_, e) -> e) l) and add_field_type bv ft = match ft.pfield_desc with @@ -84,18 +89,19 @@ let rec add_class_type bv cty = match cty.pcty_desc with Pcty_constr(l, tyl) -> add bv l; List.iter (add_type bv) tyl - | Pcty_signature (ty, fieldl) -> + | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> add_type bv ty; List.iter (add_class_type_field bv) fieldl | Pcty_fun(_, ty1, cty2) -> add_type bv ty1; add_class_type bv cty2 -and add_class_type_field bv = function +and add_class_type_field bv pctf = + match pctf.pctf_desc with Pctf_inher cty -> add_class_type bv cty - | 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 + | 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 let add_class_description bv infos = add_class_type bv infos.pci_expr @@ -116,7 +122,7 @@ let rec add_pattern bv pat = | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty | Ppat_variant(_, op) -> add_opt add_pattern bv op - | Ppat_type (li) -> add bv li + | Ppat_type li -> add bv li | Ppat_lazy p -> add_pattern bv p | Ppat_unpack _ -> () @@ -144,7 +150,7 @@ let rec add_expr bv exp = add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_for(_, e1, e2, _, e3) -> + | Pexp_for( _, e1, e2, _, e3) -> add_expr bv e1; add_expr bv e2; add_expr bv e3 | Pexp_constraint(e1, oty2, oty3) -> add_expr bv e1; @@ -152,16 +158,16 @@ let rec add_expr bv exp = add_opt add_type bv oty3 | Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2 | Pexp_send(e, m) -> add_expr bv e - | Pexp_new l -> add bv l + | Pexp_new li -> add bv li | Pexp_setinstvar(v, e) -> add_expr bv e | Pexp_override sel -> List.iter (fun (s, e) -> add_expr bv e) sel | Pexp_letmodule(id, m, e) -> - add_module bv m; add_expr (StringSet.add id bv) e + add_module bv m; add_expr (StringSet.add id.txt bv) e | Pexp_assert (e) -> add_expr bv e | Pexp_assertfalse -> () | Pexp_lazy (e) -> add_expr bv e | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t - | Pexp_object (pat, fieldl) -> + | Pexp_object { pcstr_pat = pat; pcstr_fields = fieldl } -> add_pattern bv pat; List.iter (add_class_field bv) fieldl (*> JOCAML *) | Pexp_spawn (e) -> add_expr bv e @@ -190,14 +196,14 @@ and add_modtype bv mty = Pmty_ident l -> add bv l | Pmty_signature s -> add_signature bv s | Pmty_functor(id, mty1, mty2) -> - add_modtype bv mty1; add_modtype (StringSet.add id bv) mty2 + add_modtype bv mty1; add_modtype (StringSet.add id.txt bv) mty2 | Pmty_with(mty, cstrl) -> add_modtype bv mty; List.iter (function (_, Pwith_type td) -> add_type_declaration bv td - | (_, Pwith_module lid) -> addmodule bv lid + | (_, Pwith_module (lid)) -> addmodule bv lid | (_, Pwith_typesubst td) -> add_type_declaration bv td - | (_, Pwith_modsubst lid) -> addmodule bv lid) + | (_, Pwith_modsubst (lid)) -> addmodule bv lid) cstrl | Pmty_typeof m -> add_module bv m @@ -214,12 +220,12 @@ and add_sig_item bv item = | Psig_exception(id, args) -> List.iter (add_type bv) args; bv | Psig_module(id, mty) -> - add_modtype bv mty; StringSet.add id bv + add_modtype bv mty; StringSet.add id.txt bv | Psig_recmodule decls -> - let bv' = List.fold_right StringSet.add (List.map fst decls) bv in + let bv' = List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv in List.iter (fun (id, mty) -> add_modtype bv' mty) decls; bv' - | Psig_modtype(id, mtyd) -> + | Psig_modtype(id,mtyd) -> begin match mtyd with Pmodtype_abstract -> () | Pmodtype_manifest mty -> add_modtype bv mty @@ -240,7 +246,7 @@ and add_module bv modl = | Pmod_structure s -> ignore (add_structure bv s) | Pmod_functor(id, mty, modl) -> add_modtype bv mty; - add_module (StringSet.add id bv) modl + add_module (StringSet.add id.txt bv) modl | Pmod_apply(mod1, mod2) -> add_module bv mod1; add_module bv mod2 | Pmod_constraint(modl, mty) -> @@ -266,11 +272,11 @@ and add_struct_item bv item = | Pstr_exn_rebind(id, l) -> add bv l; bv | Pstr_module(id, modl) -> - add_module bv modl; StringSet.add id bv + add_module bv modl; StringSet.add id.txt bv | Pstr_recmodule bindings -> let bv' = List.fold_right StringSet.add - (List.map (fun (id,_,_) -> id) bindings) bv in + (List.map (fun (id,_,_) -> id.txt) bindings) bv in List.iter (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl) bindings; @@ -303,7 +309,7 @@ and add_class_expr bv ce = match ce.pcl_desc with Pcl_constr(l, tyl) -> add bv l; List.iter (add_type bv) tyl - | Pcl_structure(pat, fieldl) -> + | Pcl_structure { pcstr_pat = pat; pcstr_fields = fieldl } -> add_pattern bv pat; List.iter (add_class_field bv) fieldl | Pcl_fun(_, opte, pat, ce) -> add_opt add_expr bv opte; add_pattern bv pat; add_class_expr bv ce @@ -314,13 +320,14 @@ and add_class_expr bv ce = | Pcl_constraint(ce, ct) -> add_class_expr bv ce; add_class_type bv ct -and add_class_field bv = function +and add_class_field bv pcf = + match pcf.pcf_desc with 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 + | 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_constr(ty1, ty2) -> add_type bv ty1; add_type bv ty2 | Pcf_init e -> add_expr bv e and add_class_declaration bv decl = diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index ff7ff688a4..5a40cfc395 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -26,6 +26,8 @@ open Opnames open Cmo_format open Printf +let print_locations = ref true + (* Read signed and unsigned integers *) let inputu ic = @@ -399,11 +401,12 @@ let op_shapes = [ ];; let print_event ev = - let ls = ev.ev_loc.loc_start in - let le = ev.ev_loc.loc_end in - printf "File \"%s\", line %d, characters %d-%d:\n" ls.Lexing.pos_fname - ls.Lexing.pos_lnum (ls.Lexing.pos_cnum - ls.Lexing.pos_bol) - (le.Lexing.pos_cnum - ls.Lexing.pos_bol) + if !print_locations then + let ls = ev.ev_loc.loc_start in + let le = ev.ev_loc.loc_end in + printf "File \"%s\", line %d, characters %d-%d:\n" ls.Lexing.pos_fname + ls.Lexing.pos_lnum (ls.Lexing.pos_cnum - ls.Lexing.pos_bol) + (le.Lexing.pos_cnum - ls.Lexing.pos_bol) let print_instr ic = let pos = currpos ic in @@ -539,20 +542,28 @@ let dump_exe ic = let code_size = Bytesections.seek_section ic "CODE" in print_code ic code_size -let main() = - for i = 1 to Array.length Sys.argv - 1 do - let filnam = Sys.argv.(i) in - let ic = open_in_bin filnam in - if i>1 then print_newline (); - printf "## start of ocaml dump of %S\n%!" filnam; - begin try - objfile := false; dump_exe ic +let arg_list = [ + "-noloc", Arg.Clear print_locations, " : don't print source information"; +] +let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files" Sys.argv.(0) + +let first_file = ref true + +let arg_fun filename = + let ic = open_in_bin filename in + if not !first_file then print_newline (); + first_file := false; + printf "## start of ocaml dump of %S\n%!" filename; + begin try + objfile := false; dump_exe ic with Bytesections.Bad_magic_number -> - objfile := true; seek_in ic 0; dump_obj (Sys.argv.(i)) ic - end; - close_in ic; - printf "## end of ocaml dump of %S\n%!" filnam; - done; - exit 0 + objfile := true; seek_in ic 0; dump_obj filename ic + end; + close_in ic; + printf "## end of ocaml dump of %S\n%!" filename + +let main() = + Arg.parse arg_list arg_fun arg_usage; + exit 0 let _ = main () diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 222df82211..1b8c205a78 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -86,15 +86,17 @@ mkdir -p resources # stop here -> | cat >resources/ReadMe.txt <<EOF This package installs OCaml version ${VERSION}. -You need Mac OS X 10.5.x (Leopard), with the -XCode tools installed (v3.1.1 or later), and -optionally X11. +You need Mac OS X 10.7.x (Lion), with the +XCode tools installed (v3.2.6 or later). Files will be installed in the following directories: /usr/local/bin - command-line executables /usr/local/lib/ocaml - library and support files /usr/local/man - manual pages + +Note that this package installs only command-line +tools and does not include any GUI application. EOF chmod -R g-w root diff --git a/tools/make-version-header.sh b/tools/make-version-header.sh new file mode 100755 index 0000000000..22320ec16c --- /dev/null +++ b/tools/make-version-header.sh @@ -0,0 +1,43 @@ +#!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2003 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. As an exception to the # +# licensing rules of OCaml, this file is freely redistributable, # +# modified or not, without constraints. # +# # +######################################################################### + +# For maximal compatibility with older versions, we Use "ocamlc -v" +# instead of "ocamlc -vnum" or the VERSION file in .../lib/ocaml/. + +# This script extracts the components from an OCaml version number +# and provides them as C defines: +# OCAML_VERSION_MAJOR: the major version number +# OCAML_VERSION_MAJOR: the minor version number +# OCAML_VERSION_PATCHLEVEL: the patchlevel number if present, or 0 if absent +# OCAML_VERSION_ADDITIONAL: this is defined only if the additional-info +# field is present, and is a string that contains that field. +# Note that additional-info is always absent in officially-released +# versions of OCaml. + +version="`ocamlc -v | sed -n -e 's/.*version //p'`" + +major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`" +minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`" +patchlevel="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`" +suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`" + +echo "#define OCAML_VERSION_MAJOR $major" +echo "#define OCAML_VERSION_MINOR $minor" +case $patchlevel in "") patchlevel=0;; esac +echo "#define OCAML_VERSION_PATCHLEVEL $patchlevel" +case "$suffix" in + "") echo "#undef OCAML_VERSION_ADDITIONAL";; + *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";; +esac diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 42fa8ee9c2..1e0a38e108 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -97,7 +97,7 @@ let print_cma_infos (lib : Cmo_format.library) = printf "\n"; List.iter print_cmo_infos lib.lib_units -let print_cmi_infos name sign comps crcs = +let print_cmi_infos name sign crcs = printf "Unit name: %s\n" name; printf "Interfaces imported:\n"; List.iter print_name_crc crcs @@ -231,10 +231,10 @@ let dump_obj filename = close_in ic; print_cma_infos toc end else if magic_number = cmi_magic_number then begin - let (name, sign, comps) = input_value ic in - let crcs = input_value ic in + let cmi = Cmi_format.input_cmi ic in close_in ic; - print_cmi_infos name sign comps crcs + print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_sign + cmi.Cmi_format.cmi_crcs end else if magic_number = cmx_magic_number then begin let ui = (input_value ic : unit_infos) in let crc = Digest.input ic in @@ -269,10 +269,11 @@ let dump_obj filename = end end +let arg_list = [] +let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0) + let main() = - for i = 1 to Array.length Sys.argv - 1 do - dump_obj Sys.argv.(i) - done; + Arg.parse arg_list dump_obj arg_usage; exit 0 let _ = main () diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index b57a500261..731c99c1c5 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -45,6 +45,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _a () = make_archive := true; option "-a" () let _absname = option "-absname" let _annot = option "-annot" + let _binannot = option "-bin-annot" let _c = option "-c" let _cc s = option_with_arg "-cc" s let _cclib s = option_with_arg "-cclib" s @@ -104,7 +105,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\ @@ -112,6 +113,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 0ccd025c15..ad9478883c 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -198,7 +198,7 @@ let preprocess sourcefile = None -> sourcefile | Some pp -> flush Pervasives.stdout; - let tmpfile = Filename.temp_file "camlpp" "" in + let tmpfile = Filename.temp_file "ocamldep_pp" "" in let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in if Sys.command comm <> 0 then begin Misc.remove_file tmpfile; @@ -258,7 +258,8 @@ let report_err source_file exn = | 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@]@." + Format.fprintf Format.err_formatter + "@[Preprocessing error on file %s@]@." source_file | x -> raise x @@ -267,12 +268,14 @@ let read_parse_and_extract parse_function extract_function source_file = try let input_file = preprocess source_file in let ic = open_in_bin input_file in + let cleanup () = close_in ic; remove_preprocessed input_file in try let ast = parse_function ic in extract_function Depend.StringSet.empty ast; + cleanup (); !Depend.free_structure_names with x -> - close_in ic; remove_preprocessed input_file; raise x + cleanup (); raise x with x -> report_err source_file x; Depend.StringSet.empty @@ -288,8 +291,7 @@ let ml_file_dependencies source_file = print_raw_dependencies source_file extracted_deps end else begin let basename = Filename.chop_extension source_file in - let byte_targets = - if !native_only then [] else [ basename ^ ".cmo" ] in + let byte_targets = [ basename ^ ".cmo" ] in let native_targets = if !all_dependencies then [ basename ^ ".cmx"; basename ^ ".o" ] @@ -297,13 +299,16 @@ let ml_file_dependencies source_file = 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 + if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) + !mli_synonyms then (cmi_name :: init_deps, cmi_name :: init_deps), [] - else (init_deps, init_deps), ( if !all_dependencies then [cmi_name] else [] ) in + 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 (byte_targets @ extra_targets) byt_deps; print_dependencies (native_targets @ extra_targets) native_deps; end @@ -433,38 +438,38 @@ let _ = Arg.parse [ "-nojoin", Arg.Set Clflags.nojoin, "act over pure OCaml source files" ; + "-all", Arg.Set all_dependencies, + " Generate dependencies on all files"; "-I", Arg.String add_to_load_path, "<dir> Add <dir> to the list of include directories"; "-impl", Arg.String (file_dependencies_as ML), - "<f> Process <f> as a .ml file"; + "<f> Process <f> as a .ml file"; "-intf", Arg.String (file_dependencies_as MLI), - "<f> Process <f> as a .mli file"; + "<f> Process <f> as a .mli file"; "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), - "<e> Consider <e> as a synonym of the .ml extension"; + "<e> Consider <e> as a synonym of the .ml extension"; "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), - "<e> Consider <e> as a synonym of the .mli extension"; - "-sort", Arg.Set sort_files, - " Sort files according to their dependencies"; + "<e> Consider <e> as a synonym of the .mli extension"; "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), "<e> Consider <e> as a synonym of the .ml extension"; "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), "<e> Consider <e> as a synonym of the .mli extension"; "-modules", Arg.Set raw_dependencies, - " Print module dependencies in raw form (not suitable for make)"; + " 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)"; - "-all", Arg.Set all_dependencies, - " Generate dependencies on all files (not accommodating for make shortcomings)"; + " Generate dependencies for native-code only (no .cmo files)"; "-one-line", Arg.Set one_line, - " Output one line per file, regardless of the length"; + " Output one line per file, regardless of the length"; "-pp", Arg.String(fun s -> preprocessor := Some s), - "<cmd> Pipe sources through preprocessor <cmd>"; + "<cmd> Pipe sources through preprocessor <cmd>"; "-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"; + "-sort", Arg.Set sort_files, + " Sort files according to their dependencies"; "-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 9650e5a8de..34e4698b9f 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -28,6 +28,7 @@ and caml_opts = ref [] (* -ccopt to pass to jocamlc, jocamlopt *) and dynlink = ref supports_shared_libraries and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and jocamlc -cclib *) +and c_Lopts = ref [] (* options to pass to mksharedlib and jocamlc -cclib *) and c_opts = ref [] (* options to pass to mksharedlib and jocamlc -ccopt *) and ld_opts = ref [] (* options to pass only to the linker *) and jocamlc = ref (compiler_path "jocamlc") @@ -93,7 +94,7 @@ let parse_arguments argv = else if starts_with s "-l" then c_libs := s :: !c_libs else if starts_with s "-L" then - (c_opts := s :: !c_opts; + (c_Lopts := s :: !c_Lopts; let l = chop_prefix s "-L" in if not (Filename.is_relative l) then rpath := l :: !rpath) else if s = "-jocamlc" || s = "-ocamlc" then @@ -137,6 +138,8 @@ let parse_arguments argv = (fun r -> r := List.rev !r) [ bytecode_objs; native_objs; caml_libs; caml_opts; c_libs; c_objs; c_opts; ld_opts; rpath ]; +(* Put -L options in front of -l options in -cclib to mimic -ccopt behavior *) + c_libs := !c_Lopts @ !c_libs; if !output_c = "" then output_c := !output diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml index 0b4a8b0926..be1eddd739 100644 --- a/tools/ocamlmktop.ml +++ b/tools/ocamlmktop.ml @@ -14,4 +14,4 @@ let _ = let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in - exit(Sys.command("ocamlc -linkall toplevellib.cma " ^ args ^ " topstart.cmo")) + exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo")) diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl index fea57f2573..33128c4bb8 100644 --- a/tools/ocamlmktop.tpl +++ b/tools/ocamlmktop.tpl @@ -13,4 +13,5 @@ # $Id$ -exec %%BINDIR%%/jocamlc -linkall toplevellib.cma "$@" topstart.cmo +exec %%BINDIR%%/jocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo + diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml new file mode 100644 index 0000000000..5a64ea0164 --- /dev/null +++ b/tools/ocamloptp.ml @@ -0,0 +1,160 @@ +(***********************************************************************) +(* *) +(* 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 <options> <files>\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 _binannot = option "-bin-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" +(*>JOCAML *) + let _nojoin = option "-nojoin" +(*<JOCAML *) + + 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 9374ad728e..df2b569cb3 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -288,8 +288,8 @@ and rw_exp iflag sexp = | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp - | Pexp_object (_, fieldl) -> - List.iter (rewrite_class_field iflag) fieldl + | Pexp_object cl -> + List.iter (rewrite_class_field iflag) cl.pcstr_fields | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp | Pexp_open (_, e) -> rewrite_exp iflag e @@ -325,24 +325,25 @@ and rewrite_trymatching l = (* Rewrite a class definition *) -and rewrite_class_field iflag = - function +and rewrite_class_field iflag cf = + match cf.pcf_desc with Pcf_inher (_, cexpr, _) -> rewrite_class_expr iflag cexpr - | Pcf_val (_, _, _, sexp, _) -> rewrite_exp iflag sexp - | Pcf_meth (_, _, _, ({pexp_desc = Pexp_function _} as sexp), _) -> + | Pcf_val (_, _, _, sexp) -> rewrite_exp iflag sexp + | Pcf_meth (_, _, _, ({pexp_desc = Pexp_function _} as sexp)) -> rewrite_exp iflag sexp - | Pcf_meth (_, _, _, sexp, loc) -> + | Pcf_meth (_, _, _, sexp) -> + let loc = cf.pcf_loc in if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp else rewrite_exp iflag sexp | Pcf_init sexp -> rewrite_exp iflag sexp - | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () + | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> () and rewrite_class_expr iflag cexpr = match cexpr.pcl_desc with Pcl_constr _ -> () - | Pcl_structure (_, fields) -> - List.iter (rewrite_class_field iflag) fields + | Pcl_structure st -> + List.iter (rewrite_class_field iflag) st.pcstr_fields | Pcl_fun (_, _, _, cexpr) -> rewrite_class_expr iflag cexpr | Pcl_apply (cexpr, exprs) -> diff --git a/tools/pprintast.ml b/tools/pprintast.ml new file mode 100644 index 0000000000..1a54ba49ad --- /dev/null +++ b/tools/pprintast.ml @@ -0,0 +1,2264 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified fo 3.12.0 and fixed *) + +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) + +open Asttypes +open Format +open Location +open Lexing +open Parsetree + + +(* borrowed from printast.ml *) +let fmt_position f l = + if l.pos_fname = "" && l.pos_lnum = 1 + then fprintf f "%d" l.pos_cnum + else if l.pos_lnum = -1 + then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) +;; + +let fmt_location f loc = + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; +;; + +let line i f s (*...*) = + fprintf f "%s" (String.make (2*i) ' '); + fprintf f s (*...*) +;; + +let label i ppf x = line i ppf "label=\"%s\"\n" x;; + +(* end borrowing *) + + +let indent = 1 ;; (* standard indentation increment *) +let bar_on_first_case = true ;; + +(* These sets of symbols are taken from the manual. However, it's + unclear what the sets infix_symbols and prefix_symbols are for, as + operator_chars, which contains their union seems to be the only set + useful to determine whether an identifier is prefix or infix. + The set postfix_chars I added, which is the set of characters allowed + at the end of an identifier to allow for internal MetaOCaml variable + renaming. *) + +let prefix_symbols = [ '!'; '?'; '~' ] ;; +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; + '*'; '/'; '$'; '%' ] ;; +let operator_chars = [ '!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; + ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~' ] ;; +let numeric_chars = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ] ;; + +type fixity = + | Infix + | Prefix ;; + +let is_infix fx = + match fx with + | Infix -> true + | Prefix -> false ;; + +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ] ;; + + +(* +let is_special_infix_string s = + List.exists (fun x -> (x = s)) special_infix_strings ;; +*) + +let is_in_list e l = List.exists (fun x -> (x = e)) l + + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string s = + if ((is_in_list s special_infix_strings) + || (is_in_list (String.get s 0) infix_symbols)) then Infix else Prefix + +let fixity_of_longident li = + match li.txt with + | Longident.Lident name -> + fixity_of_string name +(* This is wrong (and breaks RTT): + | Longident.Ldot (_, name) + when is_in_list name special_infix_strings -> Infix +*) + | _ -> Prefix ;; + +let fixity_of_exp e = + match e.pexp_desc with + | Pexp_ident (li) -> + (fixity_of_longident li) +(* + | Pexp_cspval (_,li) -> + if false (* default valu of !Clflags.prettycsp *) + then (fixity_of_longident li) + else Prefix +*) + | _ -> Prefix ;; + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident s -> fprintf f "%s" s; + | Longident.Ldot(y, s) when is_in_list s special_infix_strings -> + fprintf f "%a.( %s )@ " fmt_longident_aux y s +(* This is wrong (and breaks RTT): + fprintf f "@ %s@ " s +*) + | Longident.Ldot (y, s) -> + begin + match s.[0] with + 'a'..'z' | 'A'..'Z' -> + fprintf f "%a.%s" fmt_longident_aux y s + | _ -> + fprintf f "%a.( %s )@ " fmt_longident_aux y s + + end + + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; +;; + +let fmt_longident ppf x = fprintf ppf "%a" fmt_longident_aux x.txt;; + +let fmt_char f c = + let i = int_of_char c in + if (i < 32) || (i >= 128) then + fprintf f "'\\%03d'" (Char.code c) + else + match c with + '\'' | '\\' -> + fprintf f "'\\%c'" c + | _ -> + fprintf f "'%c'" c;; + +let fmt_constant f x = + match x with + | Const_int (i) -> + if (i < 0) then fprintf f "(%d)" i + else fprintf f "%d" i; + | Const_char (c) -> fprintf f "%a" fmt_char c ; + | Const_string (s) -> + fprintf f "%S" s; + | Const_float (s) -> + if ((String.get s 0) = '-') then fprintf f "(%s)" s + else fprintf f "%s" s; + (* maybe parenthesize all floats for consistency? *) + | Const_int32 (i) -> + if i < 0l then fprintf f "(%ldl)" i + else fprintf f "%ldl" i; + | Const_int64 (i) -> + if i < 0L then fprintf f "(%LdL)" i + else fprintf f "%LdL" i; + | Const_nativeint (i) -> + if i < 0n then + fprintf f "(%ndn)" i + else fprintf f "%ndn" i; +;; + +let fmt_mutable_flag ppf x = + match x with + | Immutable -> (); + | Mutable -> fprintf ppf "mutable "; +;; + +let string ppf s = + fprintf ppf "%s" s ;; + +let text ppf s = + fprintf ppf "%s" s.txt ;; + +let constant_string ppf s = + fprintf ppf "\"%s\"" (String.escaped s) ;; + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "virtual "; + | Concrete -> (); +;; + +let list f ppf l = + let n = List.length l in + List.iteri (fun i fmt -> + f ppf fmt; + if i < n-1 then + Format.fprintf ppf "\n") + l;; + +(* List2 - applies f to each element in list l, placing break hints + and a separator string between the resulting outputs. *) + +let rec list2 f ppf l ?(indent=0) ?(space=1) ?(breakfirst=false) + ?(breaklast=false) sep = + match l with + [] -> if (breaklast=true) then pp_print_break ppf space indent; + | (last::[]) -> + if (breakfirst=true) then pp_print_break ppf space indent; + f ppf last; + if (breaklast=true) then pp_print_break ppf space indent; + | (first::rest) -> + if (breakfirst=true) then pp_print_break ppf space indent; + f ppf first ; + fprintf ppf sep; + pp_print_break ppf space indent; + list2 f ppf rest ~indent:indent ~space:space + ~breakfirst:false ~breaklast:breaklast sep ;; + +let type_var_print ppf str = + fprintf ppf "'%s" str.txt ;; + +let type_var_option_print ppf str = + match str with + None -> () (* TODO check *) + | Some str -> + fprintf ppf "'%s" str.txt ;; + +let fmt_class_params ppf (l, loc) = + let length = (List.length l) in + if (length = 0) then () + else if (length = 1) then + fprintf ppf "%s@ " (List.hd l) + else begin + fprintf ppf "(" ; + list2 string ppf l "," ; + fprintf ppf ")@ " ; + end ;; + +let fmt_class_params_def ppf (l, loc) = + let length = (List.length l) in + if (length = 0) then () + else begin + fprintf ppf "[" ; + list2 type_var_print ppf l "," ; + fprintf ppf "]@ "; + end ;; + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> (); + | Recursive | Default -> fprintf f " rec"; + (* todo - what is "default" recursion?? + this seemed safe, as it's better to falsely make a non-recursive + let recursive than the opposite. *) +;; + +let fmt_direction_flag ppf x = + match x with + | Upto -> fprintf ppf "to" ; + | Downto -> fprintf ppf "downto" ; +;; + +let fmt_private_flag f x = + match x with + | Public -> () ; (* fprintf f "Public"; *) + | Private -> fprintf f "private "; +;; + +let option f ppf x = (* DELETE *) + match x with + | None -> () ; + | Some x -> + line 0 ppf "Some\n"; + f ppf x; +;; + +let option_quiet_p f ppf x = + match x with + | None -> (); + | Some x -> + fprintf ppf "@ (" ; + f ppf x; + fprintf ppf ")"; +;; + +let option_quiet f ppf x = + match x with + | None -> (); + | Some x -> + fprintf ppf "@ " ; + f ppf x; +;; + +let rec expression_is_terminal_list exp = + match exp with + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]")}, None, _)} + -> true ; + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::")}, + Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} + -> (expression_is_terminal_list exp2) + | {pexp_desc = _} + -> false +;; + +let rec core_type ppf x = + match x.ptyp_desc with + | Ptyp_any -> fprintf ppf "_"; (* done *) + | Ptyp_var (s) -> fprintf ppf "'%s" s; (* done *) + | Ptyp_arrow (l, ct1, ct2) -> (* done *) + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + (match l with + | "" -> core_type ppf ct1; + | s when (String.get s 0 = '?') -> + (match ct1.ptyp_desc with + | Ptyp_constr ({ txt = Longident.Lident ("option")}, l) -> + fprintf ppf "%s :@ " s ; + type_constr_list ppf l ; + | _ -> core_type ppf ct1; (* todo: what do we do here? *) + ); + | s -> + fprintf ppf "%s :@ " s ; + core_type ppf ct1; (* todo: what do we do here? *) + ); + fprintf ppf "@ ->@ " ; + core_type ppf ct2 ; + fprintf ppf ")" ; + pp_close_box ppf () ; + | Ptyp_tuple l -> (* done *) + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + list2 core_type ppf l " *" ; + fprintf ppf ")" ; + pp_close_box ppf () ; + | Ptyp_constr (li, l) -> (* done *) + pp_open_hovbox ppf indent ; + type_constr_list ppf ~space:true l ; + fprintf ppf "%a" fmt_longident li ; + pp_close_box ppf () ; + | Ptyp_variant (l, closed, low) -> + pp_open_hovbox ppf indent ; + (match closed with + | true -> fprintf ppf "[ " ; + | false -> fprintf ppf "[> " ; + ); + list2 type_variant_helper ppf l " |" ; + fprintf ppf " ]"; + pp_close_box ppf () ; + | Ptyp_object (l) -> + if ((List.length l) > 0) then begin + pp_open_hovbox ppf indent ; + fprintf ppf "< " ; + list2 core_field_type ppf l " ;" ; + fprintf ppf " >" ; + pp_close_box ppf () ; + end else fprintf ppf "< >" ; +(* line i ppf "Ptyp_object\n"; + list i core_field_type ppf l; *) + | Ptyp_class (li, l, low) -> (* done... sort of *) + pp_open_hovbox ppf indent ; + list2 core_type ppf l ~breaklast:true "" ; + fprintf ppf "#%a" fmt_longident li; + if ((List.length low) < 0) then begin (* done, untested *) + fprintf ppf "@ [> " ; + list2 class_var ppf low "" ; + fprintf ppf " ]"; + end ; + pp_close_box ppf (); +(* line i ppf "Ptyp_class %a\n" fmt_longident li; + list i core_type ppf l; + list i string ppf low *) + | Ptyp_alias (ct, s) -> (* done *) + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + core_type ppf ct ; + fprintf ppf "@ as@ '%s)" s; + pp_close_box ppf () ; + | Ptyp_poly (sl, ct) -> (* done? *) + pp_open_hovbox ppf indent ; + if ((List.length sl) > 0) then begin + list2 (fun ppf x -> fprintf ppf "'%s" x) ppf sl ~breaklast:true ""; + fprintf ppf ".@ " ; + end ; + core_type ppf ct ; + pp_close_box ppf () ; + | Ptyp_package (lid, cstrs) -> + fprintf ppf "(module %a@ " fmt_longident lid; + pp_open_hovbox ppf indent; + begin match cstrs with + [] -> () + | _ -> + fprintf ppf "@ with@ "; + string_x_core_type_ands ppf cstrs ; + end; + pp_close_box ppf (); + fprintf ppf ")"; + +and class_var ppf s = + fprintf ppf "`%s" s ; + +and core_field_type ppf x = + match x.pfield_desc with + | Pfield (s, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "%s :@ " s; + core_type ppf ct; + pp_close_box ppf () ; + | Pfield_var -> + fprintf ppf ".."; + +and type_constr_list ppf ?(space=false) l = + match (List.length l) with + | 0 -> () + | 1 -> list2 core_type ppf l "" ; + if (space) then fprintf ppf " " ; + | _ -> fprintf ppf "(" ; + list2 core_type ppf l "," ; + fprintf ppf ")" ; + if (space) then fprintf ppf " " ; + +and pattern_with_label ppf x s = + if (s = "") then simple_pattern ppf x + else begin + let s = + if (String.get s 0 = '?') then begin + fprintf ppf "?" ; + String.sub s 1 ((String.length s) - 1) + end else begin + fprintf ppf "~" ; + s + end in + fprintf ppf "%s" s ; + match x.ppat_desc with + | Ppat_var (s2) -> + if (s <> s2.txt) then begin + fprintf ppf ":" ; + simple_pattern ppf x ; + end + | _ -> fprintf ppf ":" ; + simple_pattern ppf x + end ; + +and pattern_with_when ppf whenclause x = + match whenclause with + | None -> pattern ppf x ; + | Some (e) -> + pp_open_hovbox ppf indent ; + pattern ppf x ; + fprintf ppf "@ when@ " ; + expression ppf e ; + pp_close_box ppf () ; + +and pattern ppf x = + match x.ppat_desc with + | Ppat_construct (li, po, b) -> + pp_open_hovbox ppf indent ; + (match li.txt,po with + | Longident.Lident("::"), + Some ({ppat_desc = Ppat_tuple([pat1; pat2])}) -> + fprintf ppf "(" ; + pattern ppf pat1 ; + fprintf ppf "@ ::@ " ; + pattern_list_helper ppf pat2 ; + fprintf ppf ")"; + | _,_ -> + fprintf ppf "%a" fmt_longident li; + option_quiet pattern_in_parens ppf po;); + pp_close_box ppf () ; +(* OXX what is this boolean ?? + bool i ppf b; *) + + | _ -> + simple_pattern ppf x + +and simple_pattern ppf x = + match x.ppat_desc with + | Ppat_construct (li, None, _) -> + fprintf ppf "%a@ " fmt_longident li + | Ppat_any -> fprintf ppf "_"; (* OXX done *) + | Ppat_var ({txt = txt}) -> + if (is_infix (fixity_of_string txt)) || List.mem txt.[0] prefix_symbols then + fprintf ppf "(%s)" txt (* OXX done *) + else + fprintf ppf "%s" txt; + | Ppat_alias (p, s) -> (* OXX done ... *) + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + pattern ppf p ; + fprintf ppf " as@ %s)" s.txt; + pp_close_box ppf () ; + | Ppat_constant (c) -> (* OXX done *) + fprintf ppf "%a" fmt_constant c; + | Ppat_tuple (l) -> (* OXX done *) + fprintf ppf "@[<hov 1>("; + list2 pattern ppf l ","; + fprintf ppf "@])"; + | Ppat_variant (l, po) -> + (match po with + | None -> + fprintf ppf "`%s" l; + | Some (p) -> + pp_open_hovbox ppf indent ; + fprintf ppf "(`%s@ " l ; + pattern ppf p ; + fprintf ppf ")" ; + pp_close_box ppf () ; + ); + | Ppat_record (l, closed) -> (* OXX done *) + fprintf ppf "{" ; + list2 longident_x_pattern ppf l ";" ; + begin match closed with + Open -> fprintf ppf "_ "; + | Closed -> () + end; + fprintf ppf "}" ; + | Ppat_array (l) -> (* OXX done *) + pp_open_hovbox ppf 2 ; + fprintf ppf "[|" ; + list2 pattern ppf l ";" ; + fprintf ppf "|]" ; + pp_close_box ppf () ; + | Ppat_or (p1, p2) -> (* OXX done *) + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + pattern ppf p1 ; + fprintf ppf "@ | " ; + pattern ppf p2 ; + fprintf ppf ")" ; + pp_close_box ppf () ; + | Ppat_constraint (p, ct) -> (* OXX done, untested *) + fprintf ppf "(" ; + pattern ppf p ; + fprintf ppf " :" ; + pp_print_break ppf 1 indent ; + core_type ppf ct ; + fprintf ppf ")" ; + | Ppat_type (li) -> (* OXX done *) + fprintf ppf "#%a" fmt_longident li ; + | Ppat_lazy p -> + pp_open_hovbox ppf indent ; + fprintf ppf "(lazy @ "; + pattern ppf p ; + fprintf ppf ")" ; + pp_close_box ppf () + | Ppat_unpack (s) -> + fprintf ppf "(module@ %s)@ " s.txt + | _ -> + fprintf ppf "@[<hov 1>("; + pattern ppf x; + fprintf ppf "@])"; + +and simple_expr ppf x = + match x.pexp_desc with + | Pexp_construct (li, None, _) -> + fprintf ppf "%a@ " fmt_longident li + | Pexp_ident (li) -> (* was (li, b) *) + if is_infix (fixity_of_longident li) + || match li.txt with + | Longident.Lident (li) -> List.mem li.[0] prefix_symbols + | _ -> false + then + fprintf ppf "(%a)" fmt_longident li + else + fprintf ppf "%a" fmt_longident li ; + | Pexp_constant (c) -> fprintf ppf "%a" fmt_constant c; + | Pexp_pack (me) -> + fprintf ppf "(module@ "; + pp_open_hovbox ppf indent; + module_expr ppf me; + pp_close_box ppf (); + fprintf ppf ")"; + | Pexp_newtype (lid, e) -> + fprintf ppf "fun (type %s)@ " lid; + expression ppf e + | Pexp_tuple (l) -> + fprintf ppf "@[<hov 1>("; + list2 simple_expr ppf l ","; + fprintf ppf ")@]"; + | Pexp_variant (l, eo) -> + pp_open_hovbox ppf indent ; + fprintf ppf "`%s" l ; + option_quiet expression ppf eo ; + pp_close_box ppf () ; + | Pexp_record (l, eo) -> + pp_open_hovbox ppf indent ; (* maybe just 1? *) + fprintf ppf "{" ; + begin + match eo with + None -> () + | Some e -> + expression ppf e; + fprintf ppf "@ with@ " + end; + list2 longident_x_expression ppf l ";" ; + fprintf ppf "}" ; + pp_close_box ppf () ; + | Pexp_array (l) -> + pp_open_hovbox ppf 2 ; + fprintf ppf "[|" ; + list2 simple_expr ppf l ";" ; + fprintf ppf "|]" ; + pp_close_box ppf () ; + | Pexp_while (e1, e2) -> + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "while@ " ; + expression ppf e1 ; + fprintf ppf " do" ; + pp_close_box ppf () ; + pp_print_break ppf 1 indent ; + expression_sequence ppf e2 ~first:false; + pp_print_break ppf 1 0 ; + fprintf ppf "done" ; + pp_close_box ppf () ; + | Pexp_for (s, e1, e2, df, e3) -> + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "for %s =@ " s.txt ; + expression ppf e1 ; + fprintf ppf "@ %a@ " fmt_direction_flag df ; + expression ppf e2 ; + fprintf ppf " do" ; + pp_close_box ppf () ; + + pp_print_break ppf 1 indent ; + expression_sequence ppf ~first:false e3 ; + pp_print_break ppf 1 0 ; + fprintf ppf "done" ; + pp_close_box ppf () ; + | _ -> + fprintf ppf "(@ "; + expression ppf x; + fprintf ppf "@ )" + +and expression ppf x = + match x.pexp_desc with + | Pexp_let (rf, l, e) -> + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + pp_close_box ppf () ; + fprintf ppf " in" ; + pp_print_space ppf () ; + expression_sequence ppf ~first:false ~indent:0 e ; + pp_close_box ppf () ; + | Pexp_function (label, None, [ + { ppat_desc = Ppat_var { txt ="*opt*" } }, + { pexp_desc = Pexp_let (_, [ + arg , + { pexp_desc = Pexp_match (_, [ _; _, eo ] ) } ], e) } + ] + ) -> + expression ppf { x with pexp_desc = Pexp_function(label, Some eo, + [arg, e]) } + + | Pexp_function (p, eo, l) -> + if (List.length l = 1) then begin + pp_open_hvbox ppf indent; + fprintf ppf "fun " ; + pattern_x_expression_case_single ppf (List.hd l) eo p + end else begin + pp_open_hvbox ppf 0; + fprintf ppf "function" ; + option_quiet expression_in_parens ppf eo ; + pp_print_space ppf () ; + pattern_x_expression_case_list ppf l ; + end ; + pp_close_box ppf (); + | Pexp_apply (e, l) -> (* was (e, l, _) *) + let fixity = (is_infix (fixity_of_exp e)) in + let sd = + (match e.pexp_desc with + | Pexp_ident ({ txt = Longident.Ldot (Longident.Lident(modname), valname) }) + -> (modname, valname) + | Pexp_ident ({ txt = Longident.Lident(valname) }) + -> ("",valname) + | _ -> ("","")) + in + (match sd,l with + | ("Array", "get"), [(_,exp1) ; (_,exp2)] -> + pp_open_hovbox ppf indent; + (match exp1.pexp_desc with + | Pexp_ident (_) -> + expression ppf exp1 ; + | _ -> + expression_in_parens ppf exp1 ; + ); + fprintf ppf "."; + expression_in_parens ppf exp2; + pp_close_box ppf (); + | ("Array", "set"), [(_,array) ; (_,index) ; (_, valu)] -> + pp_open_hovbox ppf indent; + (match array.pexp_desc with + | Pexp_ident (_) -> + expression ppf array ; + | _ -> + expression_in_parens ppf array ; + ); + fprintf ppf "."; + expression_in_parens ppf index; + fprintf ppf "@ <-@ "; + expression ppf valu; + pp_close_box ppf (); + | ("","!"),[(_,exp1)] -> + fprintf ppf "!" ; + simple_expr ppf exp1 ; +(* | ("","raise"),[(_,exp)] -> + fprintf ppf "raising [" ; + expression ppf exp; + fprintf ppf "], says %s" st; *) + | (_,_) -> + pp_open_hovbox ppf (indent + 1) ; + fprintf ppf "(" ; + if (fixity = false) then + begin + (match e.pexp_desc with + | Pexp_ident(_) -> expression ppf e ; + | Pexp_send (_,_) -> expression ppf e ; + | _ -> pp_open_hovbox ppf indent; + expression_in_parens ppf e ; + pp_close_box ppf () ); + fprintf ppf "@ " ; + list2 label_x_expression_param ppf l ""; + end + else begin + match l with + [ arg1; arg2 ] -> + label_x_expression_param ppf arg1 ; + pp_print_space ppf () ; + (match e.pexp_desc with + | Pexp_ident(li) -> +(* override parenthesization of infix identifier *) + fprintf ppf "%a" fmt_longident li ; + | _ -> simple_expr ppf e) ; + pp_print_space ppf () ; + label_x_expression_param ppf arg2 + | _ -> +(* fprintf ppf "(" ; *) + simple_expr ppf e ; +(* fprintf ppf ")" ; *) + list2 label_x_expression_param ppf l ~breakfirst:true "" + end ; + fprintf ppf ")" ; + pp_close_box ppf () ;) + | Pexp_match (e, l) -> + fprintf ppf "(" ; + pp_open_hvbox ppf 0; + pp_open_hovbox ppf 2; + fprintf ppf "match@ " ; + expression ppf e ; + fprintf ppf " with" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + pattern_x_expression_case_list ppf l ; + pp_close_box ppf () ; + fprintf ppf ")" ; + | Pexp_try (e, l) -> + fprintf ppf "("; + pp_open_vbox ppf 0; (* <-- always break here, says style manual *) + pp_open_hvbox ppf 0; + fprintf ppf "try"; + pp_print_break ppf 1 indent ; + expression_sequence ppf ~first:false e; + pp_print_break ppf 1 0; + fprintf ppf "with"; + pp_close_box ppf (); + pp_print_cut ppf (); + pattern_x_expression_case_list ppf l ; + pp_close_box ppf (); + fprintf ppf ")"; + | Pexp_construct (li, eo, b) -> + (match li.txt with + | Longident.Lident ("::") -> + (match eo with + Some ({pexp_desc = Pexp_tuple ([exp1 ; exp2])}) -> + pp_open_hovbox ppf indent ; + if (expression_is_terminal_list exp2) then begin + fprintf ppf "[" ; + simple_expr ppf exp1 ; + expression_list_helper ppf exp2 ; + fprintf ppf "]" ; + end else begin + pp_open_hovbox ppf indent ; + fprintf ppf "(@ "; + simple_expr ppf exp1 ; + fprintf ppf " ) ::@ " ; + expression_list_nonterminal ppf exp2 ; + fprintf ppf "@ " ; + pp_close_box ppf () ; + end ; + pp_close_box ppf () ; + | _ -> assert false + ); + | Longident.Lident ("()") -> fprintf ppf "()" ; + | _ -> + fprintf ppf "("; + pp_open_hovbox ppf indent ; + fmt_longident ppf li; + option_quiet expression_in_parens ppf eo; + pp_close_box ppf () ; + fprintf ppf ")" + ); + | Pexp_field (e, li) -> + pp_open_hovbox ppf indent ; + (match e.pexp_desc with + | Pexp_ident (_) -> + simple_expr ppf e ; + | _ -> + expression_in_parens ppf e ; + ); + fprintf ppf ".%a" fmt_longident li ; + pp_close_box ppf () ; + | Pexp_setfield (e1, li, e2) -> + pp_open_hovbox ppf indent ; + (match e1.pexp_desc with + | Pexp_ident (_) -> + simple_expr ppf e1 ; + | _ -> + expression_in_parens ppf e1 ; + ); + fprintf ppf ".%a" fmt_longident li; + fprintf ppf "@ <-@ "; + expression ppf e2; + pp_close_box ppf () ; + | Pexp_ifthenelse (e1, e2, eo) -> + fprintf ppf "@[<hv 0>" ; + expression_if_common ppf e1 e2 eo; + fprintf ppf "@]"; + + | Pexp_sequence (e1, e2) -> + fprintf ppf "@[<hv 0>begin" ; + pp_print_break ppf 1 indent ; +(* "@;<1 2>" ; *) + expression_sequence ppf ~first:false x ; + fprintf ppf "@;<1 0>end@]" ; + | Pexp_constraint (e, cto1, cto2) -> + (match (cto1, cto2) with + | (None, None) -> expression ppf e ; + | (Some (x1), Some (x2)) -> + pp_open_hovbox ppf 2 ; + fprintf ppf "(" ; + expression ppf e ; + fprintf ppf " :@ " ; + core_type ppf x1 ; + fprintf ppf " :>@ " ; + core_type ppf x2 ; + fprintf ppf ")" ; + pp_close_box ppf () ; + | (Some (x), None) -> + pp_open_hovbox ppf 2 ; + fprintf ppf "(" ; + expression ppf e ; + fprintf ppf " :@ " ; + core_type ppf x ; + fprintf ppf ")" ; + pp_close_box ppf () + | (None, Some (x)) -> + pp_open_hovbox ppf 2 ; + fprintf ppf "(" ; + expression ppf e ; + fprintf ppf " :>@ " ; + core_type ppf x ; + fprintf ppf ")" ; + pp_close_box ppf () + ) + | Pexp_when (e1, e2) -> + assert false ; +(* This is a wierd setup. The ocaml phrase + "pattern when condition -> expression" + found in pattern matching contexts is encoded as: + "pattern -> when condition expression" + Thus, the when clause ("when condition"), which one might expect + to be part of the pattern, is encoded as part of the expression + following the pattern. + A "when clause" should never exist in a vaccum. It should always + occur in a pattern matching context and be printed as part of the + pattern (in pattern_x_expression_case_list). + Thus these Pexp_when expressions are printed elsewhere, and if + this code is executed, an error has occurred. *) + | Pexp_send (e, s) -> + pp_open_hovbox ppf indent; + (match e.pexp_desc with + | Pexp_ident(_) -> + expression ppf e; + fprintf ppf "#%s" s; + | _ -> + fprintf ppf "(" ; + expression_in_parens ppf e; + fprintf ppf "@,#%s" s; + fprintf ppf ")" + ); + pp_close_box ppf (); (* bug fixed? *) + | Pexp_new (li) -> + pp_open_hovbox ppf indent; + fprintf ppf "new@ %a" fmt_longident li; + pp_close_box ppf (); + | Pexp_setinstvar (s, e) -> + pp_open_hovbox ppf indent; + fprintf ppf "%s <-@ " s.txt; + expression ppf e; + pp_close_box ppf (); + | Pexp_override (l) -> + pp_open_hovbox ppf indent ; + fprintf ppf "{< " ; + if ((List.length l) > 0) then begin + list2 string_x_expression ppf l ";"; + fprintf ppf " " ; + end ; + fprintf ppf ">}" ; + pp_close_box ppf () ; + | Pexp_letmodule (s, me, e) -> + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "let module %s =@ " s.txt ; + module_expr ppf me ; + fprintf ppf " in" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + expression_sequence ppf ~first:false ~indent:0 e ; + pp_close_box ppf () ; + | Pexp_assert (e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "assert@ " ; + expression ppf e ; + pp_close_box ppf () ; + | Pexp_assertfalse -> + fprintf ppf "assert false" ; + | Pexp_lazy (e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "lazy@ " ; + simple_expr ppf e ; + pp_close_box ppf () ; + | Pexp_poly (e, cto) -> +(* should this even print by itself? *) + (match cto with + | None -> expression ppf e ; + | Some (ct) -> + pp_open_hovbox ppf indent ; + expression ppf e ; + fprintf ppf "@ (* poly:@ " ; + core_type ppf ct ; + fprintf ppf " *)" ; + pp_close_box ppf () ); + | Pexp_object cs -> + pp_open_hovbox ppf indent ; + class_structure ppf cs ; + pp_close_box ppf () ; + | Pexp_open (lid, e) -> + pp_open_hvbox ppf 0 ; + fprintf ppf "let open@ %a in@ " fmt_longident lid; + expression_sequence ppf ~first:false ~indent:0 e ; + pp_close_box ppf () ; +(*>JOCAML *) + | Pexp_spawn e -> (* Cf. lazy *) + pp_open_hovbox ppf indent ; + fprintf ppf "spawn@ " ; + simple_expr ppf e ; + pp_close_box ppf () + | Pexp_par (e1,e2) -> (* Cf. sequence *) + fprintf ppf "@[<hv 0>(" ; + pp_print_break ppf 1 indent ; + expression_par ppf ~first:false x ; + fprintf ppf "@;<1 0>)@]" + | Pexp_reply (e,id) -> (* Cf. lazy *) + pp_open_hovbox ppf indent ; + fprintf ppf "reply@ " ; + simple_expr ppf e ; + fprintf ppf "@ to %s" id.txt ; + pp_close_box ppf () + | Pexp_def (d,e) -> (* Cf. let *) + let d,ds = Misc.as_cons d in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "def " ; + auto ppf d ; + autos ppf ds ; + pp_close_box ppf () ; + fprintf ppf " in" ; + pp_print_space ppf () ; + expression_par ppf ~first:false ~indent:0 e ; + pp_close_box ppf () ; +(*<JOCAML *) + | _ -> simple_expr ppf x + +(*<JOCAML *) +and expression_par ppf ?(skip=1) ?(indent=indent) ?(first=true) expr = + if (first = true) then begin + pp_open_hvbox ppf 0 ; + expression_par ppf ~skip:skip ~indent:0 ~first:false expr ; + pp_close_box ppf () ; + end else + match expr.pexp_desc with + | Pexp_par (e1, e2) -> + simple_expr ppf e1 ; + fprintf ppf " &" ; + pp_print_break ppf skip indent ; (* "@;<1 2>" ; *) + expression_par ppf ~skip:skip ~indent:indent ~first:false e2 ; + | _ -> + expression ppf expr +(*>JOCAML *) + +and value_description ppf x = + pp_open_hovbox ppf indent ; + core_type ppf x.pval_type; + if ((List.length x.pval_prim) > 0) then begin + fprintf ppf " =@ " ; + list2 constant_string ppf x.pval_prim ""; + end ; + pp_close_box ppf () ; + +and type_declaration ppf x = + pp_open_hovbox ppf indent ; + (match x.ptype_manifest with + | None -> () + | Some(y) -> + core_type ppf y; + match x.ptype_kind with + | Ptype_variant _ | Ptype_record _ -> fprintf ppf " = " + | Ptype_abstract -> ()); + (match x.ptype_kind with + | Ptype_variant (first::rest) -> + pp_open_hovbox ppf indent ; + + pp_open_hvbox ppf 0 ; + type_variant_leaf ppf first true ; + type_variant_leaf_list ppf rest ; +(* string_x_core_type_list ppf lst; *) + pp_close_box ppf () ; + + pp_close_box ppf () ; + | Ptype_variant [] -> + assert false ; + | Ptype_abstract -> () + | Ptype_record l -> + + pp_open_hovbox ppf indent ; + + fprintf ppf "{" ; + pp_print_break ppf 0 indent ; + pp_open_hvbox ppf 0; + list2 type_record_field ppf l ";" ; + pp_close_box ppf () ; + fprintf ppf "@," ; + pp_close_box ppf () ; + fprintf ppf "}" ; + + pp_close_box ppf () ; + ); + list2 typedef_constraint ppf x.ptype_cstrs ~breakfirst:true "" ; + pp_close_box ppf () ; + +and exception_declaration ppf x = + match x with + | [] -> () + | first::rest -> + fprintf ppf "@ of@ "; + list2 core_type ppf x " *"; + +and class_type ppf x = + match x.pcty_desc with + | Pcty_signature (cs) -> + class_signature ppf cs; + | Pcty_constr (li, l) -> + pp_open_hovbox ppf indent ; + (match l with + | [] -> () + | _ -> fprintf ppf "[" ; + list2 core_type ppf l "," ; + fprintf ppf "]@ " ); + fprintf ppf "%a" fmt_longident li ; + pp_close_box ppf () ; + | Pcty_fun (l, co, cl) -> + pp_open_hovbox ppf indent ; + core_type ppf co ; + fprintf ppf " ->@ " ; + (match l with + | "" -> () ; + | _ -> fprintf ppf "[%s] " l ); (* todo - what's l *) + class_type ppf cl ; + pp_close_box ppf () ; + +and class_signature ppf { pcsig_self = ct; pcsig_fields = l } = + pp_open_hvbox ppf 0; + pp_open_hovbox ppf indent ; + fprintf ppf "object"; + (match ct.ptyp_desc with + | Ptyp_any -> () + | _ -> fprintf ppf "@ ("; + core_type ppf ct; + fprintf ppf ")" ); + pp_close_box ppf () ; + list2 class_type_field ppf l ~indent:indent ~breakfirst:true ""; + pp_print_break ppf 1 0; + fprintf ppf "end"; + +and class_type_field ppf x = + match x.pctf_desc with + | Pctf_inher (ct) -> (* todo: test this *) + pp_open_hovbox ppf indent ; + fprintf ppf "inherit@ " ; + class_type ppf ct ; + pp_close_box ppf () ; + | Pctf_val (s, mf, vf, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "val %s%s%s :@ " + (match mf with + | Mutable -> "mutable " + | _ -> "") + (match vf with + | Virtual -> "virtual " + | _ -> "") + s; + core_type ppf ct ; + pp_close_box ppf () ; + | Pctf_virt (s, pf, ct) -> (* todo: test this *) + pp_open_hovbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "method@ %avirtual@ %s" fmt_private_flag pf s ; + pp_close_box ppf () ; + fprintf ppf " :@ " ; + core_type ppf ct ; + pp_close_box ppf () ; + | Pctf_meth (s, pf, ct) -> + pp_open_hovbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "method %a%s" fmt_private_flag pf s; + pp_close_box ppf () ; + fprintf ppf " :@ " ; + core_type ppf ct ; + pp_close_box ppf () ; + | Pctf_cstr (ct1, ct2) -> + pp_open_hovbox ppf indent ; + fprintf ppf "constraint@ " ; + core_type ppf ct1; + fprintf ppf " =@ " ; + core_type ppf ct2; + pp_close_box ppf () ; + +and class_description ppf x = + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "class %a%a%s :" fmt_virtual_flag x.pci_virt + fmt_class_params_def x.pci_params x.pci_name.txt ; + pp_close_box ppf () ; + pp_print_break ppf 1 indent ; + class_type ppf x.pci_expr ; + pp_close_box ppf () ; + +and class_type_declaration ppf x = + class_type_declaration_ext ppf true x ; + +and class_type_declaration_ext ppf first x = + pp_open_hvbox ppf 0; + pp_open_hovbox ppf indent ; + fprintf ppf "%s@ %a%a%s =" (if (first) then "class type" else "and") + fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params + x.pci_name.txt ; + pp_close_box ppf (); + pp_print_break ppf 1 indent ; + class_type ppf x.pci_expr; + pp_close_box ppf (); + +and class_type_declaration_list ppf ?(first=true) l = + if (first) then pp_open_hvbox ppf 0 ; + match l with + | [] -> if (first) then pp_close_box ppf () ; + | h :: [] -> + class_type_declaration_ext ppf first h ; + pp_close_box ppf () ; + | h :: t -> + class_type_declaration_ext ppf first h ; + pp_print_space ppf () ; + class_type_declaration_list ppf ~first:false t ; + +and class_expr ppf x = + match x.pcl_desc with + | Pcl_structure (cs) -> + class_structure ppf cs ; + | Pcl_fun (l, eo, p, e) -> + pp_open_hvbox ppf indent; + pp_open_hovbox ppf indent; + fprintf ppf "fun@ "; + pattern ppf p; + fprintf ppf " ->"; + pp_close_box ppf (); + (match (eo, l) with + | (None, "") -> () ; + | (_,_) -> + pp_open_hovbox ppf indent; + fprintf ppf " (* eo: "; + option expression ppf eo; + fprintf ppf "@ label: "; + label 0 ppf l; + fprintf ppf " *)"; + pp_close_box ppf () + ); + fprintf ppf "@ "; + class_expr ppf e; + pp_close_box ppf (); + | Pcl_let (rf, l, ce) -> + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + pp_close_box ppf () ; + pp_close_box ppf () ; + fprintf ppf " in" ; + pp_print_space ppf () ; + class_expr ppf ce; + | Pcl_apply (ce, l) -> + pp_open_hovbox ppf indent ; + fprintf ppf "("; + class_expr ppf ce; + list2 label_x_expression_param ppf l ~breakfirst:true ""; + fprintf ppf ")"; + pp_close_box ppf () ; + | Pcl_constr (li, l) -> + pp_open_hovbox ppf indent; + if ((List.length l) != 0) then begin + fprintf ppf "[" ; + list2 core_type ppf l "," ; + fprintf ppf "]@ " ; + end ; + fprintf ppf "%a" fmt_longident li; + pp_close_box ppf (); + | Pcl_constraint (ce, ct) -> + pp_open_hovbox ppf indent; + fprintf ppf "("; + class_expr ppf ce; + fprintf ppf "@ : "; + class_type ppf ct; + fprintf ppf ")"; + pp_close_box ppf (); + +and class_structure ppf { pcstr_pat = p; pcstr_fields = l } = + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "object" ; + (match p.ppat_desc with + | Ppat_any -> (); + | _ -> fprintf ppf "@ " ; + pattern_in_parens ppf p ); + pp_close_box ppf () ; + list2 class_field ppf l ~indent:indent ~breakfirst:true ""; + fprintf ppf "@ end" ; + pp_close_box ppf () ; + +and override ovf = match ovf with + Override -> "!" + | Fresh -> "" + +and class_field ppf x = + match x.pcf_desc with + | Pcf_inher (ovf, ce, so) -> + pp_open_hovbox ppf indent ; + fprintf ppf "inherit%s@ " (override ovf); + class_expr ppf ce; + (match so with + | None -> (); + | Some (s) -> fprintf ppf "@ as %s" s ); + pp_close_box ppf (); + | Pcf_val (s, mf, ovf, e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "val%s %a%s =@ " (override ovf) fmt_mutable_flag mf s.txt ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + | Pcf_virt (s, pf, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "method virtual %a%s" fmt_private_flag pf s.txt ; + fprintf ppf " :@ " ; + core_type ppf ct; + pp_close_box ppf () ; + | Pcf_valvirt (s, mf, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "val virtual %s%s" + (match mf with + | Mutable -> "mutable " + | _ -> "") + s.txt; + fprintf ppf " :@ " ; + core_type ppf ct; + pp_close_box ppf () ; + | Pcf_meth (s, pf, ovf, e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "method%s %a%s" (override ovf) fmt_private_flag pf s.txt ; + (match e.pexp_desc with + | Pexp_poly (e, Some(ct)) -> + fprintf ppf " :@ " ; + core_type ppf ct ; + fprintf ppf " =@ " ; + expression ppf e ; + | _ -> + fprintf ppf " =@ " ; + expression ppf e; + ) ; +(* special Pexp_poly handling? *) + pp_close_box ppf () ; + | Pcf_constr (ct1, ct2) -> + pp_open_hovbox ppf indent ; + fprintf ppf "constraint@ "; + core_type ppf ct1; + fprintf ppf " =@ " ; + core_type ppf ct2; + pp_close_box ppf (); +(* | Pcf_let (rf, l) -> +(* at the time that this was written, Pcf_let was commented out + of the parser, rendering this untestable. In the interest of + completeness, the following code is designed to print what + the parser seems to expect *) +(* todo: test this, eventually *) + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + fprintf ppf " in" ; + pp_close_box ppf () ; *) + | Pcf_init (e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "initializer@ " ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + +and class_fun_helper ppf e = + match e.pcl_desc with + | Pcl_fun (l, eo, p, e) -> + pattern ppf p; + fprintf ppf "@ "; + (match (eo, l) with + | (None, "") -> () ; + | (_,_) -> + fprintf ppf "(* "; + option expression ppf eo; + label 0 ppf l; + fprintf ppf " *)@ " + ); + class_fun_helper ppf e; + | _ -> + e; + +and class_declaration_list ppf ?(first=true) l = + match l with + | [] -> + if (first = false) then pp_close_box ppf (); + | cd::l -> + let s = (if first then begin pp_open_hvbox ppf 0 ; "class" end + else begin pp_print_space ppf () ; "and" end) in + class_declaration ppf ~str:s cd ; + class_declaration_list ppf ~first:false l ; + +and class_declaration ppf ?(str="class") x = + pp_open_hvbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "%s %a%a%s@ " str fmt_virtual_flag x.pci_virt + fmt_class_params_def x.pci_params x.pci_name.txt ; + let ce = + (match x.pci_expr.pcl_desc with + | Pcl_fun (l, eo, p, e) -> + class_fun_helper ppf x.pci_expr; + | _ -> x.pci_expr) in + let ce = + (match ce.pcl_desc with + | Pcl_constraint (ce, ct) -> + fprintf ppf ":@ " ; + class_type ppf ct ; + fprintf ppf "@ " ; + ce + | _ -> ce ) in + fprintf ppf "=" ; + pp_close_box ppf () ; + fprintf ppf "@ " ; + class_expr ppf ce ; + pp_close_box ppf () ; + +and module_type ppf x = + match x.pmty_desc with + | Pmty_ident (li) -> + fprintf ppf "%a" fmt_longident li; + | Pmty_signature (s) -> + pp_open_hvbox ppf 0; + fprintf ppf "sig"; + list2 signature_item ppf s ~breakfirst:true ~indent:indent ""; + pp_print_break ppf 1 0; + fprintf ppf "end"; + pp_close_box ppf (); + | Pmty_functor (s, mt1, mt2) -> + pp_open_hvbox ppf indent; + pp_open_hovbox ppf indent; + fprintf ppf "functor@ (%s : " s.txt ; + module_type ppf mt1; + fprintf ppf ") ->"; + pp_close_box ppf (); + pp_print_space ppf (); + module_type ppf mt2; + pp_close_box ppf (); + | Pmty_with (mt, l) -> + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + module_type ppf mt ; + fprintf ppf "@ with@ " ; + longident_x_with_constraint_list ppf l ; + fprintf ppf ")" ; + pp_close_box ppf () ; + | Pmty_typeof me -> + pp_open_hovbox ppf indent ; + fprintf ppf "module type of " ; + module_expr ppf me ; + pp_close_box ppf () + +and signature ppf x = list signature_item ppf x + +and signature_item ppf x = + begin + match x.psig_desc with + | Psig_type (l) -> + let first = (List.hd l) in + let rest = (List.tl l) in + pp_open_hvbox ppf 0; + pp_open_hvbox ppf 0; + fprintf ppf "type " ; + string_x_type_declaration ppf first; + pp_close_box ppf (); + type_def_list_helper ppf rest; + pp_close_box ppf (); + | Psig_value (s, vd) -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp_open_hovbox ppf indent ; + if (is_infix (fixity_of_string s.txt)) + || List.mem s.txt.[0] prefix_symbols then + fprintf ppf "%s ( %s ) :@ " + intro s.txt (* OXX done *) + else + fprintf ppf "%s %s :@ " intro s.txt; + value_description ppf vd; + pp_close_box ppf () ; + | Psig_exception (s, ed) -> + pp_open_hovbox ppf indent ; + fprintf ppf "exception %s" s.txt; + exception_declaration ppf ed; + pp_close_box ppf (); + | Psig_class (l) -> + pp_open_hvbox ppf 0 ; + list2 class_description ppf l ""; + pp_close_box ppf () ; + | Psig_module (s, mt) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "module@ %s :" s.txt ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_type ppf mt; + pp_close_box ppf () ; + | Psig_open (li) -> + pp_open_hovbox ppf indent ; + fprintf ppf "open@ %a" fmt_longident li ; + pp_close_box ppf () ; + | Psig_include (mt) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + fprintf ppf "include@ " ; + module_type ppf mt; + pp_close_box ppf () ; + | Psig_modtype (s, md) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + fprintf ppf "module type %s" s.txt ; + (match md with + | Pmodtype_abstract -> () + | Pmodtype_manifest (mt) -> + pp_print_space ppf () ; + fprintf ppf " = " ; + module_type ppf mt; + ); + pp_close_box ppf () ; + | Psig_class_type (l) -> + class_type_declaration_list ppf l ; + | Psig_recmodule decls -> + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "module rec@ " ; + string_x_module_type_list ppf decls ; (* closes hov box *) + pp_close_box ppf () ; + end; + fprintf ppf "\n" + +and modtype_declaration ppf x = + match x with + | Pmodtype_abstract -> line 0 ppf "Pmodtype_abstract\n"; + | Pmodtype_manifest (mt) -> + line 0 ppf "Pmodtype_manifest\n"; + module_type ppf mt; + +and module_expr ppf x = + match x.pmod_desc with + | Pmod_structure (s) -> + pp_open_hvbox ppf 0; + fprintf ppf "struct"; + list2 structure_item ppf s ~breakfirst:true ~indent:indent ""; + pp_print_break ppf 1 0; + fprintf ppf "end"; + pp_close_box ppf (); (* bug fixed? *) + | Pmod_constraint (me, mt) -> + fprintf ppf "("; + pp_open_hovbox ppf indent; + module_expr ppf me; + fprintf ppf " :@ "; (* <-- incorrect indentation? *) + module_type ppf mt; + pp_close_box ppf (); + fprintf ppf ")"; + | Pmod_ident (li) -> + fprintf ppf "%a" fmt_longident li; + | Pmod_functor (s, mt, me) -> + pp_open_hvbox ppf indent ; + fprintf ppf "functor (%s : " s.txt; + module_type ppf mt; + fprintf ppf ") ->@ "; + module_expr ppf me; + pp_close_box ppf () ; + | Pmod_apply (me1, me2) -> + pp_open_hovbox ppf indent; + fprintf ppf "(" ; + module_expr ppf me1; + fprintf ppf ")" ; + pp_print_cut ppf (); + fprintf ppf "(" ; + module_expr ppf me2; + fprintf ppf ")" ; + pp_close_box ppf (); + | Pmod_unpack e -> + fprintf ppf "(val@ "; + pp_open_hovbox ppf indent; + expression ppf e; + pp_close_box ppf (); + fprintf ppf ")"; + +and structure ppf x = + list structure_item ppf x; + +(* +(* closes one box *) +and string_x_modtype_x_module ppf (s, _, mt, me) = +(* + (match me.pmod_desc with + | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_))} as mt)) -> + (* assert false ; *) (* 3.07 - should this ever happen here? *) + fprintf ppf "%s :@ " s ; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + | _ -> +*) + fprintf ppf "%s :@ " s; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; +(* ) ; *) +*) + +(* closes one box *) +and text_x_modtype_x_module ppf (s, mt, me) = +(* + (match me.pmod_desc with + | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_))} as mt)) -> + (* assert false ; *) (* 3.07 - should this ever happen here? *) + fprintf ppf "%s :@ " s ; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + | _ -> +*) + fprintf ppf "%s :@ " s.txt; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; +(* ) ; *) + +(* +(* net gain of one box (-1, +2) *) +and string_x_modtype_x_module_list ppf l = + match l with + | [] -> () + | hd :: tl -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + string_x_modtype_x_module ppf hd; (* closes a box *) + string_x_modtype_x_module_list ppf tl ; (* net open of one box *) +*) + +(* net gain of one box (-1, +2) *) +and text_x_modtype_x_module_list ppf l = + match l with + | [] -> () + | hd :: tl -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + text_x_modtype_x_module ppf hd; (* closes a box *) + text_x_modtype_x_module_list ppf tl ; (* net open of one box *) + +(* context: [hv [hov .]] returns [hv .] + closes inner hov box. *) +and string_x_module_type_list ppf ?(first=true) l = + match l with + | [] -> () ; + | hd :: tl -> + if (first=false) then begin + pp_print_space ppf () ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + end ; + string_x_module_type ppf hd ; + pp_close_box ppf () ; + string_x_module_type_list ppf ~first:false tl ; + +and string_x_module_type ppf (s, mty) = + fprintf ppf "%s :@ " s.txt ; + module_type ppf mty ; + +and structure_item ppf x = + begin + match x.pstr_desc with + | Pstr_eval (e) -> + pp_open_hvbox ppf 0 ; + fprintf ppf "let _ = " ; + expression_sequence ppf ~first:false ~indent:0 e ; + pp_close_box ppf () ; + | Pstr_type [] -> assert false + | Pstr_type (first :: rest) -> + pp_open_vbox ppf 0; + pp_open_hvbox ppf 0; + fprintf ppf "type " ; + string_x_type_declaration ppf first; + pp_close_box ppf (); + type_def_list_helper ppf rest; + pp_close_box ppf (); + | Pstr_value (rf, l) -> + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + pp_close_box ppf () ; + pp_close_box ppf () ; + | Pstr_exception (s, ed) -> + pp_open_hovbox ppf indent ; + fprintf ppf "exception@ %s" s.txt; + exception_declaration ppf ed; + pp_close_box ppf () ; + | Pstr_module (s, me) -> + pp_open_hvbox ppf indent; + pp_open_hovbox ppf indent ; + fprintf ppf "module %s" s.txt ; + (match me.pmod_desc with + | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_))} as mt)) -> + fprintf ppf " :@ " ; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + | _ -> + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + ) ; + pp_close_box ppf (); + | Pstr_open (li) -> + fprintf ppf "open %a" fmt_longident li; + | Pstr_modtype (s, mt) -> + pp_open_hovbox ppf indent; + fprintf ppf "module type %s =@ " s.txt; + module_type ppf mt; + pp_close_box ppf () ; (* bug fixed? *) + | Pstr_class (l) -> + class_declaration_list ppf l; + | Pstr_class_type (l) -> + class_type_declaration_list ppf l ; + | Pstr_primitive (s, vd) -> + pp_open_hovbox ppf indent ; + let need_parens = + match s.txt with + | "or" + | "mod" + | "land" + | "lor" + | "lxor" + | "lsl" + | "lsr" + | "asr" + -> true + + | _ -> + match s.txt.[0] with + 'a'..'z' -> false + | _ -> true + in + if need_parens then + fprintf ppf "external@ ( %s ) :@ " s.txt + else + fprintf ppf "external@ %s :@ " s.txt; + value_description ppf vd; + pp_close_box ppf () ; + | Pstr_include me -> + pp_open_hovbox ppf indent ; + fprintf ppf "include " ; + module_expr ppf me ; + pp_close_box ppf () ; + | Pstr_exn_rebind (s, li) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + fprintf ppf "exception@ %s =@ %a" s.txt fmt_longident li ; + pp_close_box ppf () ; + | Pstr_recmodule decls -> (* 3.07 *) + let l1 = (List.hd decls) in + let l2 = (List.tl decls) in + pp_open_hvbox ppf 0; (* whole recmodule box *) + pp_open_hvbox ppf indent ; (* this definition box *) + pp_open_hovbox ppf indent ; (* first line box *) + fprintf ppf "module rec " ; + text_x_modtype_x_module ppf l1; (* closes a box *) + text_x_modtype_x_module_list ppf l2; (* net opens one box *) + pp_close_box ppf () ; + pp_close_box ppf () ; + pp_close_box ppf () ; +(*>JOCAML *) + | Pstr_exn_global li -> + pp_open_hovbox ppf indent ; + fprintf ppf "def exception %a" fmt_longident li ; + pp_close_box ppf () ; + | Pstr_def ds -> (* Imitate let *) + let d,ds = Misc.as_cons ds in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "def " ; + auto ppf d ; + autos ppf ds ; + pp_close_box ppf () ; + pp_close_box ppf () +(*<JOCAML *) + end; + fprintf ppf "\n" + +(*>JOCAML *) + +and jpat ppf jp = + let jid,p = jp.pjpat_desc in + fprintf ppf "%s" jid.txt ; + pattern_in_parens ppf p + +and clause ppf cl = + let jps,e = cl.pjclause_desc in + let jp,jps = Misc.as_cons jps in + fprintf ppf "@[<hov 1>"; + list2 jpat ppf jps "&" ; + fprintf ppf "@])"; + fprintf ppf " =@ " ; + expression_par ppf e ~first:false + +(* Same trick as in pattern_x_expression_def_list *) +and clause_list ppf cls = match cls with +| [] -> () +| cl::cls -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + fprintf ppf "or " ; + clause ppf cl ; + clause_list ppf cls + +and auto ppf a = + let cls = a.pjauto_desc in + let cl,cls = Misc.as_cons cls in + pp_open_hvbox ppf 0 ; + clause ppf cl ; + clause_list ppf cls ; + pp_close_box ppf () + +and autos ppf ds = match ds with +| [] -> () +| a::ds -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + fprintf ppf "and " ; + auto ppf a ; + autos ppf ds +(*<JOCAML *) + +and type_def_list_helper ppf l = + match l with + | [] -> () + | first :: rest -> + pp_print_space ppf () ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + string_x_type_declaration ppf first; + pp_close_box ppf () ; + type_def_list_helper ppf rest ; + +and string_x_type_declaration ppf (s, td) = + let l = td.ptype_params in + (match (List.length l) with + | 0 -> () + | 1 -> list2 type_var_option_print ppf l "" ; + fprintf ppf " " ; + | _ -> pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + list2 type_var_option_print ppf l "," ; + fprintf ppf ")" ; + pp_close_box ppf (); + fprintf ppf " " ; + ); + fprintf ppf "%s" s.txt ; + (match (td.ptype_kind, td.ptype_manifest) with + | Ptype_abstract, None -> () + | Ptype_record _, _ -> fprintf ppf " = " ; + | _ , _ -> fprintf ppf " =" ; + pp_print_break ppf 1 indent ; + ); + type_declaration ppf td; + +and longident_x_with_constraint_list ?(first=true) ppf l = + match l with + | [] -> () ; + | h :: [] -> + if (first = false) then fprintf ppf "@ and " ; + longident_x_with_constraint ppf h ; + | h :: t -> + if (first = false) then fprintf ppf "@ and " ; + longident_x_with_constraint ppf h ; + fprintf ppf "@ and " ; + longident_x_with_constraint ppf h ; + longident_x_with_constraint_list ~first:false ppf t; + +and string_x_core_type_ands ?(first=true) ppf l = + match l with + | [] -> () ; + | h :: [] -> + if (first = false) then fprintf ppf "@ and " ; + string_x_core_type ppf h ; + | h :: t -> + if (first = false) then fprintf ppf "@ and " ; + string_x_core_type ppf h; + string_x_core_type_ands ~first:false ppf t; + +and string_x_core_type ppf (s, ct) = + fprintf ppf "%a@ =@ %a" fmt_longident s core_type ct + +and longident_x_with_constraint ppf (li, wc) = + match wc with + | Pwith_type (td) -> + fprintf ppf "type@ %a =@ " fmt_longident li; + type_declaration ppf td ; + | Pwith_module (li2) -> + fprintf ppf "module %a =@ %a" fmt_longident li fmt_longident li2; + | Pwith_typesubst td -> + fprintf ppf "type@ %a :=@ " fmt_longident li; + type_declaration ppf td ; + | Pwith_modsubst (li2) -> + fprintf ppf "module %a :=@ %a" fmt_longident li fmt_longident li2; + +and typedef_constraint ppf (ct1, ct2, l) = + pp_open_hovbox ppf indent ; + fprintf ppf "constraint@ " ; + core_type ppf ct1; + fprintf ppf " =@ " ; + core_type ppf ct2; + pp_close_box ppf () ; + +and type_variant_leaf ppf (s, l,_, _) first = (* TODO *) + if (first) then begin + pp_print_if_newline ppf (); + pp_print_string ppf " "; + end else begin + pp_print_space ppf (); + fprintf ppf "| " ; + end ; + pp_open_hovbox ppf indent ; + fprintf ppf "%s" s.txt ; + if ((List.length l) > 0) then begin + fprintf ppf "@ of@ " ; + list2 core_type ppf l " *" + end ; + pp_close_box ppf (); + +and type_variant_leaf_list ppf list = + match list with + | [] -> () + | first :: rest -> + type_variant_leaf ppf first false ; + type_variant_leaf_list ppf rest ; + +and type_record_field ppf (s, mf, ct,_) = + pp_open_hovbox ppf indent ; + fprintf ppf "%a%s:" fmt_mutable_flag mf s.txt ; + core_type ppf ct ; + pp_close_box ppf () ; + +and longident_x_pattern ppf (li, p) = + pp_open_hovbox ppf indent ; + fprintf ppf "%a =@ " fmt_longident li; + pattern ppf p; + pp_close_box ppf () ; + + + +and pattern_x_expression_case_list + ppf ?(first:bool=true) ?(special_first_case=bar_on_first_case) + (l:(pattern * expression) list) = + match l with + | [] -> () + | (p,e)::[] -> (* last time *) + if (first=false) then + fprintf ppf "| " ; + pp_open_hvbox ppf indent ; + let (e,w) = + (match e with + | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1)) + | _ -> (e, None)) in + pattern_with_when ppf w p ; + fprintf ppf " ->@ " ; + pp_open_hvbox ppf 0 ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + pp_close_box ppf () ; + | (p,e)::r -> (* not last *) + pp_open_hvbox ppf (indent + 2) ; + if ((first=true) && (special_first_case=false)) then begin + pp_print_if_newline ppf () ; + pp_print_string ppf " " + end else + fprintf ppf "| " ; + let (e,w) = + (match e with + | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1)) + | _ -> (e, None)) in + pattern_with_when ppf w p ; + fprintf ppf " ->@ " ; + pp_open_hvbox ppf 0 ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + pp_close_box ppf () ; + pp_print_break ppf 1 0; + (pattern_x_expression_case_list ppf ~first:false r); + +and pattern_x_expression_def ppf (p, e) = + pattern ppf p ; + fprintf ppf " =@ " ; + expression ppf e; + +and pattern_list_helper ppf p = + match p with + | {ppat_desc = Ppat_construct ({ txt = Longident.Lident("::") }, + Some ({ppat_desc = Ppat_tuple([pat1; pat2])}), + _)} + -> pattern ppf pat1 ; + fprintf ppf "@ ::@ " ; + pattern_list_helper ppf pat2 ; + | _ -> pattern ppf p ; + +and string_x_expression ppf (s, e) = + pp_open_hovbox ppf indent ; + fprintf ppf "%s =@ " s.txt ; + expression ppf e ; + pp_close_box ppf () ; + +and longident_x_expression ppf (li, e) = + pp_open_hovbox ppf indent ; + fprintf ppf "%a =@ " fmt_longident li; + simple_expr ppf e; + pp_close_box ppf () ; + +and label_x_expression_param ppf (l,e) = + match l with + | "" -> simple_expr ppf e ; + | lbl -> + if ((String.get lbl 0) = '?') then begin + fprintf ppf "%s:" lbl ; + simple_expr ppf e ; + end else begin + fprintf ppf "~%s:" lbl ; + simple_expr ppf e ; + end ; + +and expression_in_parens ppf e = + let already_has_parens = + (match e.pexp_desc with + Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Ldot ( + Longident.Lident(modname), funname) })},_) + -> (match modname,funname with + | "Array","get" -> false; + | "Array","set" -> false; + | _,_ -> true) ; + | Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Lident(funname) })},_) + -> (match funname with + | "!" -> false; + | _ -> true); + | Pexp_apply (_,_) -> true; + | Pexp_match (_,_) -> true; + | Pexp_tuple (_) -> true ; + | Pexp_constraint (_,_,_) -> true ; + | _ -> false) in + if (already_has_parens) then expression ppf e + else begin + fprintf ppf "(" ; + expression ppf e ; + fprintf ppf ")" ; + end ; + +and pattern_in_parens ppf p = + let already_has_parens = + match p.ppat_desc with + | Ppat_alias (_,_) -> true + | Ppat_tuple (_) -> true + | Ppat_or (_,_) -> true + | Ppat_constraint (_,_) -> true + | _ -> false in + if (already_has_parens) then pattern ppf p + else begin + fprintf ppf "(" ; + pattern ppf p ; + fprintf ppf ")" ; + end; + +and pattern_constr_params_option ppf po = + match po with + | None -> (); + | Some pat -> + pp_print_space ppf (); + pattern_in_parens ppf pat; + +and type_variant_helper ppf x = + match x with + | Rtag (l, b, ctl) -> (* is b important? *) + pp_open_hovbox ppf indent ; + fprintf ppf "`%s" l ; + if ((List.length ctl) != 0) then begin + fprintf ppf " of@ " ; + list2 core_type ppf ctl " *" ; + end ; + pp_close_box ppf () ; + | Rinherit (ct) -> + core_type ppf ct + +(* prints a list of definitions as found in a let statement + note! breaks "open and close boxes in same function" convention, however + does always open and close the same number of boxes. (i.e. no "net + gain or loss" of box depth. *) +and pattern_x_expression_def_list ppf l = + match l with + | [] -> () + | hd :: tl -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + fprintf ppf "and " ; + pattern_x_expression_def ppf hd; + pattern_x_expression_def_list ppf tl ; + +(* end an if statement by printing an else phrase if there is an "else" + statement in the ast. otherwise just close the box. *) +(* added: special case for "else if" case *) + +and expression_eo ppf eo extra = + match eo with + | None -> (); + | Some x -> + if extra then fprintf ppf " " + else fprintf ppf "@ " ; + match x.pexp_desc with + | Pexp_ifthenelse (e1, e2, eo) -> (* ... else if ...*) + fprintf ppf "else" ; + expression_elseif ppf (e1, e2, eo) + | Pexp_sequence (e1, e2) -> + fprintf ppf "else" ; + expression_ifbegin ppf x; (* ... else begin ... end*) + | _ -> (* ... else ... *) + pp_open_hvbox ppf indent ; + fprintf ppf "else@ " ; + expression ppf x ; + pp_close_box ppf () ; + +and expression_elseif ppf (e1,e2,eo) = + fprintf ppf " " ; + expression_if_common ppf e1 e2 eo ; + +and expression_ifbegin ppf e = + fprintf ppf " begin"; + pp_print_break ppf 1 indent ; (* "@;<1 2>"; *) + expression_sequence ppf e; + pp_print_break ppf 1 0 ; (* fprintf ppf "@;<1 0>" *) + fprintf ppf "end"; + +and expression_if_common ppf e1 e2 eo = + match eo, e2.pexp_desc with + | None, Pexp_sequence (_, _) -> + fprintf ppf "if@ " ; + expression ppf e1; + fprintf ppf "@ then@ " ; + expression_ifbegin ppf e2 + | None, _ -> + fprintf ppf "if@ " ; + expression ppf e1; + fprintf ppf "@ then@ " ; + simple_expr ppf e2 + | Some _, Pexp_sequence _ -> + fprintf ppf "if " ; + expression ppf e1; + fprintf ppf "@ then@ " ; + expression_ifbegin ppf e2; + expression_eo ppf eo true; (* ... then begin ... end *) + | Some _, _ -> + pp_open_hvbox ppf indent ; + fprintf ppf "if " ; + expression ppf e1; + fprintf ppf " then@ " ; + simple_expr ppf e2; + pp_close_box ppf () ; + expression_eo ppf eo false; + +and expression_sequence ppf ?(skip=1) ?(indent=indent) ?(first=true) expr = + if (first = true) then begin + pp_open_hvbox ppf 0 ; + expression_sequence ppf ~skip:skip ~indent:0 ~first:false expr ; + pp_close_box ppf () ; + end else + match expr.pexp_desc with + | Pexp_sequence (e1, e2) -> + simple_expr ppf e1 ; + fprintf ppf ";" ; + pp_print_break ppf skip indent ; (* "@;<1 2>" ; *) + expression_sequence ppf ~skip:skip ~indent:indent ~first:false e2 ; + | _ -> + expression ppf expr ; + +and expression_list_helper ppf exp = + match exp with + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)} + -> () ; + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") }, + Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} + -> fprintf ppf ";@ " ; + simple_expr ppf exp1 ; + expression_list_helper ppf exp2 ; + | {pexp_desc = _} + -> assert false; + +and expression_list_nonterminal ppf exp = + match exp with + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)} + -> fprintf ppf "[]" ; (* assert false; *) + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") }, + Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} + -> simple_expr ppf exp1; + fprintf ppf " ::@ "; + expression_list_nonterminal ppf exp2; + | {pexp_desc = _} + -> expression ppf exp; +; + +and directive_argument ppf x = + match x with + | Pdir_none -> () + | Pdir_string (s) -> fprintf ppf "@ \"%s\"" s; + | Pdir_int (i) -> fprintf ppf "@ %d" i; + | Pdir_ident (li) -> fprintf ppf "@ %a" fmt_longident_aux li; + | Pdir_bool (b) -> fprintf ppf "@ %s" (string_of_bool b); + +and string_x_core_type_list ppf (s, l) = + string ppf s; + list core_type ppf l; + +and string_list_x_location ppf (l, loc) = + line 0 ppf "<params> %a\n" fmt_location loc; + list string ppf l; + +and pattern_x_expression_case_single ppf (p, e) eo lbl = + (match eo with + None -> pattern_with_label ppf p lbl + | Some x -> + fprintf ppf "?" ; + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + begin + match p.ppat_desc with + Ppat_constraint ({ ppat_desc = Ppat_var s }, ct) -> + fprintf ppf "%s@ :@ %a" s.txt core_type ct + | Ppat_var s -> + fprintf ppf "%s" s.txt + | _ -> assert false + end; + fprintf ppf " =@ " ; + expression ppf x ; + fprintf ppf ")" ; + pp_close_box ppf () + ) ; + fprintf ppf " ->@ " ; + expression_sequence ppf ~indent:0 e ;; + +let rec toplevel_phrase ppf x = + match x with + | Ptop_def (s) -> + pp_open_hvbox ppf 0; + list2 structure_item ppf s ~breakfirst:false ~indent:0 ""; + pp_close_box ppf (); + | Ptop_dir (s, da) -> + pp_open_hovbox ppf indent; + fprintf ppf "#%s" s; + directive_argument ppf da; + pp_close_box ppf () ;; + +let expression ppf x = + fprintf ppf "@["; + expression ppf x; + fprintf ppf "@]";; + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let ppf = str_formatter in + expression ppf x ; + flush_str_formatter () ;; + +let toplevel_phrase ppf x = + pp_print_newline ppf () ; + toplevel_phrase ppf x; + fprintf ppf ";;" ; + pp_print_newline ppf ();; + +let print_structure = structure +let print_signature = signature + + diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml new file mode 100644 index 0000000000..dc795778ce --- /dev/null +++ b/tools/read_cmt.ml @@ -0,0 +1,81 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +let gen_annot = ref false +let gen_ml = ref false +let print_info_arg = ref false +let target_filename = ref None + +let arg_list = [ + "-o", Arg.String (fun s -> + target_filename := Some s + ), " FILE (or -) : dump to file FILE (or stdout)"; + "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file"; + "-src", Arg.Set gen_ml, " : generate an equivalent of the original source file (without comments) from a .cmt or a .cmti file"; + "-info", Arg.Set print_info_arg, " : print information on the file"; + ] + +let arg_usage = "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information" + +let print_info cmt = + let open Cmt_format in + Printf.printf "module name: %s\n" cmt.cmt_modname; + begin match cmt.cmt_annots with + Packed (_, list) -> Printf.printf "pack: %s\n" (String.concat " " list) + | Implementation _ -> Printf.printf "kind: implementation\n" + | Interface _ -> Printf.printf "kind: interface\n" + | Partial_implementation _ -> Printf.printf "kind: implementation with errors\n" + | Partial_interface _ -> Printf.printf "kind: interface with errors\n" + end; + Printf.printf "command: %s\n" (String.concat " " (Array.to_list cmt.cmt_args)); + begin match cmt.cmt_sourcefile with + None -> () + | Some name -> + Printf.printf "sourcefile: %s\n" name; + end; + Printf.printf "build directory: %s\n" cmt.cmt_builddir; + List.iter (fun dir -> Printf.printf "load path: %s\n%!" dir) cmt.cmt_loadpath; + begin + match cmt.cmt_source_digest with + None -> () + | Some digest -> Printf.printf "source digest: %s\n" (Digest.to_hex digest); + end; + begin + match cmt.cmt_interface_digest with + None -> () + | Some digest -> Printf.printf "interface digest: %s\n" (Digest.to_hex digest); + end; + List.iter (fun (name, digest) -> + Printf.printf "import: %s %s\n" name (Digest.to_hex digest); + ) (List.sort compare cmt.cmt_imports); + Printf.printf "%!"; + () + +let _ = + Clflags.annotations := true; + + Arg.parse arg_list (fun filename -> + if + Filename.check_suffix filename ".cmt" || + Filename.check_suffix filename ".cmti" + then begin + (* init_path(); *) + let cmt = Cmt_format.read_cmt filename in + if !gen_annot then Cmt2annot.gen_annot !target_filename filename cmt; + if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt; + if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt; + end else begin + Printf.fprintf stderr "Error: the file must have an extension in .cmt or .cmti.\n%!"; + Arg.usage arg_list arg_usage + end + ) arg_usage + diff --git a/tools/setignore b/tools/setignore index 708ed26cc1..2c2e067040 100755 --- a/tools/setignore +++ b/tools/setignore @@ -27,6 +27,7 @@ *.byte *.native program +program.exe .depend .depend.nt diff --git a/tools/typedtreeIter.ml b/tools/typedtreeIter.ml new file mode 100644 index 0000000000..ad293fbfa5 --- /dev/null +++ b/tools/typedtreeIter.ml @@ -0,0 +1,654 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +(* +TODO: + - 2012/05/10: Follow camlp4 way of building map and iter using classes + and inheritance ? +*) + +open Asttypes +open Typedtree + +module type IteratorArgument = sig + + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_declaration : type_declaration -> unit + val enter_exception_declaration : + exception_declaration -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_modtype_declaration : modtype_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_expr : class_expr -> unit + val enter_class_signature : class_signature -> unit + val enter_class_declaration : class_declaration -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_core_field_type : core_field_type -> unit + val enter_class_structure : class_structure -> unit + val enter_class_field : class_field -> unit + val enter_structure_item : structure_item -> unit + + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_declaration : type_declaration -> unit + val leave_exception_declaration : + exception_declaration -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_modtype_declaration : modtype_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_expr : class_expr -> unit + val leave_class_signature : class_signature -> unit + val leave_class_declaration : class_declaration -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_core_field_type : core_field_type -> unit + val leave_class_structure : class_structure -> unit + val leave_class_field : class_field -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : pattern -> expression -> unit + val leave_binding : pattern -> expression -> unit + val leave_bindings : rec_flag -> unit + + end + +module MakeIterator(Iter : IteratorArgument) : sig + + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + val iter_class_expr : class_expr -> unit + + end = struct + + let may_iter f v = + match v with + None -> () + | Some x -> f x + + + open Misc + open Asttypes + + let rec iter_structure str = + Iter.enter_structure str; + List.iter iter_structure_item str.str_items; + Iter.leave_structure str + + + and iter_binding (pat, exp) = + Iter.enter_binding pat exp; + iter_pattern pat; + iter_expression exp; + Iter.leave_binding pat exp + + and iter_bindings rec_flag list = + Iter.enter_bindings rec_flag; + List.iter iter_binding list; + Iter.leave_bindings rec_flag + + and iter_structure_item item = + Iter.enter_structure_item item; + begin + match item.str_desc with + Tstr_eval exp -> iter_expression exp + | Tstr_value (rec_flag, list) -> + iter_bindings rec_flag list + | Tstr_primitive (id, _, v) -> iter_value_description v + | Tstr_type list -> + List.iter (fun (id, _, decl) -> iter_type_declaration decl) list + | Tstr_exception (id, _, decl) -> iter_exception_declaration decl + | Tstr_exn_rebind (id, _, p, _) -> () + | Tstr_module (id, _, mexpr) -> + iter_module_expr mexpr + | Tstr_recmodule list -> + List.iter (fun (id, _, mtype, mexpr) -> + iter_module_type mtype; + iter_module_expr mexpr) list + | Tstr_modtype (id, _, mtype) -> + iter_module_type mtype + | Tstr_open _ -> () + | Tstr_class list -> + List.iter (fun (ci, _, _) -> + Iter.enter_class_declaration ci; + iter_class_expr ci.ci_expr; + Iter.leave_class_declaration ci; + ) list + | Tstr_class_type list -> + List.iter (fun (id, _, ct) -> + Iter.enter_class_type_declaration ct; + iter_class_type ct.ci_expr; + Iter.leave_class_type_declaration ct; + ) list + | Tstr_include (mexpr, _) -> + iter_module_expr mexpr + | Tstr_def _|Tstr_loc _|Tstr_exn_global (_, _) -> + assert false (* TODO *) + end; + Iter.leave_structure_item item + + and iter_value_description v = + Iter.enter_value_description v; + iter_core_type v.val_desc; + Iter.leave_value_description v + + and iter_type_declaration decl = + Iter.enter_type_declaration decl; + List.iter (fun (ct1, ct2, loc) -> + iter_core_type ct1; + iter_core_type ct2 + ) decl.typ_cstrs; + begin match decl.typ_kind with + Ttype_abstract -> () + | Ttype_variant list -> + List.iter (fun (s, _, cts, loc) -> + List.iter iter_core_type cts + ) list + | Ttype_record list -> + List.iter (fun (s, _, mut, ct, loc) -> + iter_core_type ct + ) list + end; + begin match decl.typ_manifest with + None -> () + | Some ct -> iter_core_type ct + end; + Iter.leave_type_declaration decl + + and iter_exception_declaration decl = + Iter.enter_exception_declaration decl; + List.iter iter_core_type decl.exn_params; + Iter.leave_exception_declaration decl; + + and iter_pattern pat = + Iter.enter_pattern pat; + List.iter (fun (cstr, _) -> match cstr with + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; + begin + match pat.pat_desc with + Tpat_any -> () + | Tpat_var (id, _) -> () + | Tpat_alias (pat1, _, _) -> iter_pattern pat1 + | Tpat_constant cst -> () + | Tpat_tuple list -> + List.iter iter_pattern list + | Tpat_construct (path, _, _, args, _) -> + List.iter iter_pattern args + | Tpat_variant (label, pato, _) -> + begin match pato with + None -> () + | Some pat -> iter_pattern pat + end + | Tpat_record (list, closed) -> + List.iter (fun (path, _, _, pat) -> iter_pattern pat) list + | Tpat_array list -> List.iter iter_pattern list + | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 + | Tpat_lazy p -> iter_pattern p + end; + Iter.leave_pattern pat + + and option f x = match x with None -> () | Some e -> f e + + and iter_expression exp = + Iter.enter_expression exp; + List.iter (function (cstr, _) -> + match cstr with + Texp_constraint (cty1, cty2) -> + option iter_core_type cty1; option iter_core_type cty2 + | Texp_open (path, _, _) -> () + | Texp_poly cto -> option iter_core_type cto + | Texp_newtype s -> ()) + exp.exp_extra; + begin + match exp.exp_desc with + Texp_ident (path, _, _) -> () + | Texp_constant cst -> () + | Texp_let (rec_flag, list, exp) -> + iter_bindings rec_flag list; + iter_expression exp + | Texp_function (label, cases, _) -> + iter_bindings Nonrecursive cases + | Texp_apply (exp, list) -> + iter_expression exp; + List.iter (fun (label, expo, _) -> + match expo with + None -> () + | Some exp -> iter_expression exp + ) list + | Texp_match (exp, list, _) -> + iter_expression exp; + iter_bindings Nonrecursive list + | Texp_try (exp, list) -> + iter_expression exp; + iter_bindings Nonrecursive list + | Texp_tuple list -> + List.iter iter_expression list + | Texp_construct (path, _, _, args, _) -> + List.iter iter_expression args + | Texp_variant (label, expo) -> + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_record (list, expo) -> + List.iter (fun (path, _, _, exp) -> + iter_expression exp + ) list; + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_field (exp, path, _, label) -> + iter_expression exp + | Texp_setfield (exp1, path, _ , label, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_array list -> + List.iter iter_expression list + | Texp_ifthenelse (exp1, exp2, expo) -> + iter_expression exp1; + iter_expression exp2; + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_sequence (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_while (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_for (id, _, exp1, exp2, dir, exp3) -> + iter_expression exp1; + iter_expression exp2; + iter_expression exp3 + | Texp_when (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_send (exp, meth, expo) -> + iter_expression exp; + begin + match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_new (path, _, _) -> () + | Texp_instvar (_, path, _) -> () + | Texp_setinstvar (_, _, _, exp) -> + iter_expression exp + | Texp_override (_, list) -> + List.iter (fun (path, _, exp) -> + iter_expression exp + ) list + | Texp_letmodule (id, _, mexpr, exp) -> + iter_module_expr mexpr; + iter_expression exp + | Texp_assert exp -> iter_expression exp + | Texp_assertfalse -> () + | Texp_lazy exp -> iter_expression exp + | Texp_object (cl, _) -> + iter_class_structure cl + | Texp_pack (mexpr) -> + iter_module_expr mexpr +(*>JOCAML *) + | Texp_asyncsend (_, _)|Texp_spawn _|Texp_par (_, _)|Texp_null + | Texp_reply (_, _)|Texp_def (_, _)|Texp_loc (_, _) -> + assert false (* TODO *) +(*<JOCAML *) + end; + Iter.leave_expression exp; + + and iter_package_type pack = + Iter.enter_package_type pack; + List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields; + Iter.leave_package_type pack; + + and iter_signature sg = + Iter.enter_signature sg; + List.iter iter_signature_item sg.sig_items; + Iter.leave_signature sg; + + and iter_signature_item item = + Iter.enter_signature_item item; + begin + match item.sig_desc with + Tsig_value (id, _, v) -> + iter_value_description v + | Tsig_type list -> + List.iter (fun (id, _, decl) -> + iter_type_declaration decl + ) list + | Tsig_exception (id, _, decl) -> + iter_exception_declaration decl + | Tsig_module (id, _, mtype) -> + iter_module_type mtype + | Tsig_recmodule list -> + List.iter (fun (id, _, mtype) -> iter_module_type mtype) list + | Tsig_modtype (id, _, mdecl) -> + iter_modtype_declaration mdecl + | Tsig_open _ -> () + | Tsig_include (mty,_) -> iter_module_type mty + | Tsig_class list -> + List.iter iter_class_description list + | Tsig_class_type list -> + List.iter iter_class_type_declaration list + end; + Iter.leave_signature_item item; + + and iter_modtype_declaration mdecl = + Iter.enter_modtype_declaration mdecl; + begin + match mdecl with + Tmodtype_abstract -> () + | Tmodtype_manifest mtype -> iter_module_type mtype + end; + Iter.leave_modtype_declaration mdecl; + + + and iter_class_description cd = + Iter.enter_class_description cd; + iter_class_type cd.ci_expr; + Iter.leave_class_description cd; + + and iter_class_type_declaration cd = + Iter.enter_class_type_declaration cd; + iter_class_type cd.ci_expr; + Iter.leave_class_type_declaration cd; + + and iter_module_type mty = + Iter.enter_module_type mty; + begin + match mty.mty_desc with + Tmty_ident (path, _) -> () + | Tmty_signature sg -> iter_signature sg + | Tmty_functor (id, _, mtype1, mtype2) -> + iter_module_type mtype1; iter_module_type mtype2 + | Tmty_with (mtype, list) -> + iter_module_type mtype; + List.iter (fun (path, _, withc) -> + iter_with_constraint withc + ) list + | Tmty_typeof mexpr -> + iter_module_expr mexpr + end; + Iter.leave_module_type mty; + + and iter_with_constraint cstr = + Iter.enter_with_constraint cstr; + begin + match cstr with + Twith_type decl -> iter_type_declaration decl + | Twith_module _ -> () + | Twith_typesubst decl -> iter_type_declaration decl + | Twith_modsubst _ -> () + end; + Iter.leave_with_constraint cstr; + + and iter_module_expr mexpr = + Iter.enter_module_expr mexpr; + begin + match mexpr.mod_desc with + Tmod_ident (p, _) -> () + | Tmod_structure st -> iter_structure st + | Tmod_functor (id, _, mtype, mexpr) -> + iter_module_type mtype; + iter_module_expr mexpr + | Tmod_apply (mexp1, mexp2, _) -> + iter_module_expr mexp1; + iter_module_expr mexp2 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> + iter_module_expr mexpr + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + iter_module_expr mexpr; + iter_module_type mtype + | Tmod_unpack (exp, mty) -> + iter_expression exp +(* iter_module_type mty *) + end; + Iter.leave_module_expr mexpr; + + and iter_class_expr cexpr = + Iter.enter_class_expr cexpr; + begin + match cexpr.cl_desc with + | Tcl_constraint (cl, None, _, _, _ ) -> + iter_class_expr cl; + | Tcl_structure clstr -> iter_class_structure clstr + | Tcl_fun (label, pat, priv, cl, partial) -> + iter_pattern pat; + List.iter (fun (id, _, exp) -> iter_expression exp) priv; + iter_class_expr cl + + | Tcl_apply (cl, args) -> + iter_class_expr cl; + List.iter (fun (label, expo, _) -> + match expo with + None -> () + | Some exp -> iter_expression exp + ) args + + | Tcl_let (rec_flat, bindings, ivars, cl) -> + iter_bindings rec_flat bindings; + List.iter (fun (id, _, exp) -> iter_expression exp) ivars; + iter_class_expr cl + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + iter_class_expr cl; + iter_class_type clty + + | Tcl_ident (_, _, tyl) -> + List.iter iter_core_type tyl + end; + Iter.leave_class_expr cexpr; + + and iter_class_type ct = + Iter.enter_class_type ct; + begin + match ct.cltyp_desc with + Tcty_signature csg -> iter_class_signature csg + | Tcty_constr (path, _, list) -> + List.iter iter_core_type list + | Tcty_fun (label, ct, cl) -> + iter_core_type ct; + iter_class_type cl + end; + Iter.leave_class_type ct; + + and iter_class_signature cs = + Iter.enter_class_signature cs; + iter_core_type cs.csig_self; + List.iter iter_class_type_field cs.csig_fields; + Iter.leave_class_signature cs + + + and iter_class_type_field ctf = + Iter.enter_class_type_field ctf; + begin + match ctf.ctf_desc with + Tctf_inher ct -> iter_class_type ct + | Tctf_val (s, mut, virt, ct) -> + iter_core_type ct + | Tctf_virt (s, priv, ct) -> + iter_core_type ct + | Tctf_meth (s, priv, ct) -> + iter_core_type ct + | Tctf_cstr (ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + end; + Iter.leave_class_type_field ctf + + and iter_core_type ct = + Iter.enter_core_type ct; + begin + match ct.ctyp_desc with + Ttyp_any -> () + | Ttyp_var s -> () + | Ttyp_arrow (label, ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Ttyp_tuple list -> List.iter iter_core_type list + | Ttyp_constr (path, _, list) -> + List.iter iter_core_type list + | Ttyp_object list -> + List.iter iter_core_field_type list + | Ttyp_class (path, _, list, labels) -> + List.iter iter_core_type list + | Ttyp_alias (ct, s) -> + iter_core_type ct + | Ttyp_variant (list, bool, labels) -> + List.iter iter_row_field list + | Ttyp_poly (list, ct) -> iter_core_type ct + | Ttyp_package pack -> iter_package_type pack + end; + Iter.leave_core_type ct; + + and iter_core_field_type cft = + Iter.enter_core_field_type cft; + begin match cft.field_desc with + Tcfield_var -> () + | Tcfield (s, ct) -> iter_core_type ct + end; + Iter.leave_core_field_type cft; + + and iter_class_structure cs = + Iter.enter_class_structure cs; + iter_pattern cs.cstr_pat; + List.iter iter_class_field cs.cstr_fields; + Iter.leave_class_structure cs; + + + and iter_row_field rf = + match rf with + Ttag (label, bool, list) -> + List.iter iter_core_type list + | Tinherit ct -> iter_core_type ct + + and iter_class_field cf = + Iter.enter_class_field cf; + begin + match cf.cf_desc with + Tcf_inher (ovf, cl, super, _vals, _meths) -> + iter_class_expr cl + | Tcf_constr (cty, cty') -> + iter_core_type cty; + iter_core_type cty' + | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) -> + iter_core_type cty + | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) -> + iter_expression exp + | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) -> + iter_core_type cty + | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) -> + iter_expression exp +(* | Tcf_let (rec_flag, bindings, exps) -> + iter_bindings rec_flag bindings; + List.iter (fun (id, _, exp) -> iter_expression exp) exps; *) + | Tcf_init exp -> + iter_expression exp + end; + Iter.leave_class_field cf; + + end + +module DefaultIteratorArgument = struct + + let enter_structure _ = () + let enter_value_description _ = () + let enter_type_declaration _ = () + let enter_exception_declaration _ = () + let enter_pattern _ = () + let enter_expression _ = () + let enter_package_type _ = () + let enter_signature _ = () + let enter_signature_item _ = () + let enter_modtype_declaration _ = () + let enter_module_type _ = () + let enter_module_expr _ = () + let enter_with_constraint _ = () + let enter_class_expr _ = () + let enter_class_signature _ = () + let enter_class_declaration _ = () + let enter_class_description _ = () + let enter_class_type_declaration _ = () + let enter_class_type _ = () + let enter_class_type_field _ = () + let enter_core_type _ = () + let enter_core_field_type _ = () + let enter_class_structure _ = () + let enter_class_field _ = () + let enter_structure_item _ = () + + + let leave_structure _ = () + let leave_value_description _ = () + let leave_type_declaration _ = () + let leave_exception_declaration _ = () + let leave_pattern _ = () + let leave_expression _ = () + let leave_package_type _ = () + let leave_signature _ = () + let leave_signature_item _ = () + let leave_modtype_declaration _ = () + let leave_module_type _ = () + let leave_module_expr _ = () + let leave_with_constraint _ = () + let leave_class_expr _ = () + let leave_class_signature _ = () + let leave_class_declaration _ = () + let leave_class_description _ = () + let leave_class_type_declaration _ = () + let leave_class_type _ = () + let leave_class_type_field _ = () + let leave_core_type _ = () + let leave_core_field_type _ = () + let leave_class_structure _ = () + let leave_class_field _ = () + let leave_structure_item _ = () + + let enter_binding _ _ = () + let leave_binding _ _ = () + + let enter_bindings _ = () + let leave_bindings _ = () + + end + + diff --git a/tools/typedtreeIter.mli b/tools/typedtreeIter.mli new file mode 100644 index 0000000000..1aedead2aa --- /dev/null +++ b/tools/typedtreeIter.mli @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + + +module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_declaration : type_declaration -> unit + val enter_exception_declaration : + exception_declaration -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_modtype_declaration : modtype_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_expr : class_expr -> unit + val enter_class_signature : class_signature -> unit + val enter_class_declaration : class_declaration -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_core_field_type : core_field_type -> unit + val enter_class_structure : class_structure -> unit + val enter_class_field : class_field -> unit + val enter_structure_item : structure_item -> unit + + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_declaration : type_declaration -> unit + val leave_exception_declaration : + exception_declaration -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_modtype_declaration : modtype_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_expr : class_expr -> unit + val leave_class_signature : class_signature -> unit + val leave_class_declaration : class_declaration -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_core_field_type : core_field_type -> unit + val leave_class_structure : class_structure -> unit + val leave_class_field : class_field -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : pattern -> expression -> unit + val leave_binding : pattern -> expression -> unit + val leave_bindings : rec_flag -> unit + + end + +module MakeIterator : + functor + (Iter : IteratorArgument) -> + sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + val iter_class_expr : class_expr -> unit + end + +module DefaultIteratorArgument : IteratorArgument + diff --git a/tools/untypeast.ml b/tools/untypeast.ml new file mode 100644 index 0000000000..8e3853cd49 --- /dev/null +++ b/tools/untypeast.ml @@ -0,0 +1,556 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +open Misc +open Asttypes +open Typedtree +open Parsetree + +(* +Some notes: + + * For Pexp_function, we cannot go back to the exact original version + when there is a default argument, because the default argument is + translated in the typer. The code, if printed, will not be parsable because + new generated identifiers are not correct. + + * For Pexp_apply, it is unclear whether arguments are reordered, especially + when there are optional arguments. + + * TODO: check Ttype_variant -> Ptype_variant (stub None) + +*) + + +let rec lident_of_path path = + match path with + Path.Pident id -> Longident.Lident (Ident.name id) + | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) + +let rec untype_structure str = + List.map untype_structure_item str.str_items + +and untype_structure_item item = + let desc = + match item.str_desc with + Tstr_eval exp -> Pstr_eval (untype_expression exp) + | Tstr_value (rec_flag, list) -> + Pstr_value (rec_flag, List.map (fun (pat, exp) -> + untype_pattern pat, untype_expression exp) list) + | Tstr_primitive (id, name, v) -> + Pstr_primitive (name, untype_value_description v) + | Tstr_type list -> + Pstr_type (List.map (fun (id, name, decl) -> + name, untype_type_declaration decl) list) + | Tstr_exception (id, name, decl) -> + Pstr_exception (name, untype_exception_declaration decl) + | Tstr_exn_rebind (id, name, p, lid) -> + Pstr_exn_rebind (name, lid) + | Tstr_module (id, name, mexpr) -> + Pstr_module (name, untype_module_expr mexpr) + | Tstr_recmodule list -> + Pstr_recmodule (List.map (fun (id, name, mtype, mexpr) -> + name, untype_module_type mtype, + untype_module_expr mexpr) list) + | Tstr_modtype (id, name, mtype) -> + Pstr_modtype (name, untype_module_type mtype) + | Tstr_open (path, lid) -> Pstr_open (lid) + | Tstr_class list -> + Pstr_class (List.map (fun (ci, _, _) -> + { pci_virt = ci.ci_virt; + pci_params = ci.ci_params; + pci_name = ci.ci_id_name; + pci_expr = untype_class_expr ci.ci_expr; + pci_variance = ci.ci_variance; + pci_loc = ci.ci_loc; + } + ) list) + | Tstr_class_type list -> + Pstr_class_type (List.map (fun (id, name, ct) -> + { + pci_virt = ct.ci_virt; + pci_params = ct.ci_params; + pci_name = ct.ci_id_name; + pci_expr = untype_class_type ct.ci_expr; + pci_variance = ct.ci_variance; + pci_loc = ct.ci_loc; + } + ) list) + | Tstr_include (mexpr, _) -> + Pstr_include (untype_module_expr mexpr) +(*> JOCAML *) + | Tstr_def _ + | Tstr_loc _ -> assert false (* TODO *) + | Tstr_exn_global (_,lid) -> + Pstr_exn_global lid +(*< JOCAML *) + in + { pstr_desc = desc; pstr_loc = item.str_loc; } + +and untype_value_description v = + { + pval_prim = v.val_prim; + pval_type = untype_core_type v.val_desc; + pval_loc = v.val_loc } + +and untype_type_declaration decl = + { + ptype_params = decl.typ_params; + ptype_cstrs = List.map (fun (ct1, ct2, loc) -> + (untype_core_type ct1, + untype_core_type ct2, loc) + ) decl.typ_cstrs; + ptype_kind = (match decl.typ_kind with + Ttype_abstract -> Ptype_abstract + | Ttype_variant list -> + Ptype_variant (List.map (fun (s, name, cts, loc) -> + (name, List.map untype_core_type cts, None, loc) + ) list) + | Ttype_record list -> + Ptype_record (List.map (fun (s, name, mut, ct, loc) -> + (name, mut, untype_core_type ct, loc) + ) list) + ); + ptype_private = decl.typ_private; + ptype_manifest = (match decl.typ_manifest with + None -> None + | Some ct -> Some (untype_core_type ct)); + ptype_variance = decl.typ_variance; + ptype_loc = decl.typ_loc; + } + +and untype_exception_declaration decl = + List.map untype_core_type decl.exn_params + +and untype_pattern pat = + let desc = + match pat with + { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name) } -> Ppat_unpack name + | { pat_extra=[Tpat_type (path, lid), _] } -> Ppat_type lid + | { pat_extra= (Tpat_constraint ct, _) :: rem } -> + Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct) + | _ -> + match pat.pat_desc with + Tpat_any -> Ppat_any + | Tpat_var (id, name) -> + begin + match (Ident.name id).[0] with + 'A'..'Z' -> + Ppat_unpack name + | _ -> + Ppat_var name + end + | Tpat_alias (pat, id, name) -> + Ppat_alias (untype_pattern pat, name) + | Tpat_constant cst -> Ppat_constant cst + | Tpat_tuple list -> + Ppat_tuple (List.map untype_pattern list) + | Tpat_construct (path, lid, _, args, explicit_arity) -> + Ppat_construct (lid, + (match args with + [] -> None + | args -> Some + { ppat_desc = Ppat_tuple (List.map untype_pattern args); + ppat_loc = pat.pat_loc; } + ), explicit_arity) + | Tpat_variant (label, pato, _) -> + Ppat_variant (label, match pato with + None -> None + | Some pat -> Some (untype_pattern pat)) + | Tpat_record (list, closed) -> + Ppat_record (List.map (fun (path, lid, _, pat) -> + lid, untype_pattern pat) list, closed) + | Tpat_array list -> Ppat_array (List.map untype_pattern list) + | Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2) + | Tpat_lazy p -> Ppat_lazy (untype_pattern p) + in + { + ppat_desc = desc; + ppat_loc = pat.pat_loc; + } + +and option f x = match x with None -> None | Some e -> Some (f e) + +and untype_extra (extra, loc) sexp = + let desc = + match extra with + Texp_constraint (cty1, cty2) -> + Pexp_constraint (sexp, + option untype_core_type cty1, + option untype_core_type cty2) + | Texp_open (path, lid, _) -> Pexp_open (lid, sexp) + | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) + | Texp_newtype s -> Pexp_newtype (s, sexp) + in + { pexp_desc = desc; + pexp_loc = loc } + +and untype_expression exp = + let desc = + match exp.exp_desc with + Texp_ident (path, lid, _) -> Pexp_ident (lid) + | Texp_constant cst -> Pexp_constant cst + | Texp_let (rec_flag, list, exp) -> + Pexp_let (rec_flag, + List.map (fun (pat, exp) -> + untype_pattern pat, untype_expression exp) list, + untype_expression exp) + | Texp_function (label, cases, _) -> + Pexp_function (label, None, + List.map (fun (pat, exp) -> + (untype_pattern pat, untype_expression exp)) cases) + | Texp_apply (exp, list) -> + Pexp_apply (untype_expression exp, + List.fold_right (fun (label, expo, _) list -> + match expo with + None -> list + | Some exp -> (label, untype_expression exp) :: list + ) list []) + | Texp_match (exp, list, _) -> + Pexp_match (untype_expression exp, + List.map (fun (pat, exp) -> + untype_pattern pat, untype_expression exp) list) + | Texp_try (exp, list) -> + Pexp_try (untype_expression exp, + List.map (fun (pat, exp) -> + untype_pattern pat, untype_expression exp) list) + | Texp_tuple list -> + Pexp_tuple (List.map untype_expression list) + | Texp_construct (path, lid, _, args, explicit_arity) -> + Pexp_construct (lid, + (match args with + [] -> None + | args -> Some + { pexp_desc = Pexp_tuple (List.map untype_expression args); + pexp_loc = exp.exp_loc; } + ), explicit_arity) + | Texp_variant (label, expo) -> + Pexp_variant (label, match expo with + None -> None + | Some exp -> Some (untype_expression exp)) + | Texp_record (list, expo) -> + Pexp_record (List.map (fun (path, lid, _, exp) -> + lid, untype_expression exp + ) list, + match expo with + None -> None + | Some exp -> Some (untype_expression exp)) + | Texp_field (exp, path, lid, label) -> + Pexp_field (untype_expression exp, lid) + | Texp_setfield (exp1, path, lid, label, exp2) -> + Pexp_setfield (untype_expression exp1, lid, + untype_expression exp2) + | Texp_array list -> + Pexp_array (List.map untype_expression list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Pexp_ifthenelse (untype_expression exp1, + untype_expression exp2, + match expo with + None -> None + | Some exp -> Some (untype_expression exp)) + | Texp_sequence (exp1, exp2) -> + Pexp_sequence (untype_expression exp1, untype_expression exp2) + | Texp_while (exp1, exp2) -> + Pexp_while (untype_expression exp1, untype_expression exp2) + | Texp_for (id, name, exp1, exp2, dir, exp3) -> + Pexp_for (name, + untype_expression exp1, untype_expression exp2, + dir, untype_expression exp3) + | Texp_when (exp1, exp2) -> + Pexp_when (untype_expression exp1, untype_expression exp2) + | Texp_send (exp, meth, _) -> + Pexp_send (untype_expression exp, match meth with + Tmeth_name name -> name + | Tmeth_val id -> Ident.name id) + | Texp_new (path, lid, _) -> Pexp_new (lid) + | Texp_instvar (_, path, name) -> + Pexp_ident ({name with txt = lident_of_path path}) + | Texp_setinstvar (_, path, lid, exp) -> + Pexp_setinstvar (lid, untype_expression exp) + | Texp_override (_, list) -> + Pexp_override (List.map (fun (path, lid, exp) -> + lid, untype_expression exp + ) list) + | Texp_letmodule (id, name, mexpr, exp) -> + Pexp_letmodule (name, untype_module_expr mexpr, + untype_expression exp) + | Texp_assert exp -> Pexp_assert (untype_expression exp) + | Texp_assertfalse -> Pexp_assertfalse + | Texp_lazy exp -> Pexp_lazy (untype_expression exp) + | Texp_object (cl, _) -> + Pexp_object (untype_class_structure cl) + | Texp_pack (mexpr) -> + Pexp_pack (untype_module_expr mexpr) +(*>JOCAML *) + |Texp_asyncsend (_, _)|Texp_spawn _|Texp_par (_, _)|Texp_null + | Texp_reply (_, _)|Texp_def (_, _)|Texp_loc (_, _) -> + assert false (* TODO *) +(*<JOCAML *) + in + List.fold_right untype_extra exp.exp_extra + { pexp_loc = exp.exp_loc; + pexp_desc = desc } + +and untype_package_type pack = + (pack.pack_txt, + List.map (fun (s, ct) -> + (s, untype_core_type ct)) pack.pack_fields) + +and untype_signature sg = + List.map untype_signature_item sg.sig_items + +and untype_signature_item item = + let desc = + match item.sig_desc with + Tsig_value (id, name, v) -> + Psig_value (name, untype_value_description v) + | Tsig_type list -> + Psig_type (List.map (fun (id, name, decl) -> + name, untype_type_declaration decl + ) list) + | Tsig_exception (id, name, decl) -> + Psig_exception (name, untype_exception_declaration decl) + | Tsig_module (id, name, mtype) -> + Psig_module (name, untype_module_type mtype) + | Tsig_recmodule list -> + Psig_recmodule (List.map (fun (id, name, mtype) -> + name, untype_module_type mtype) list) + | Tsig_modtype (id, name, mdecl) -> + Psig_modtype (name, untype_modtype_declaration mdecl) + | Tsig_open (path, lid) -> Psig_open (lid) + | Tsig_include (mty, lid) -> Psig_include (untype_module_type mty) + | Tsig_class list -> + Psig_class (List.map untype_class_description list) + | Tsig_class_type list -> + Psig_class_type (List.map untype_class_type_declaration list) + in + { psig_desc = desc; + psig_loc = item.sig_loc; + } + +and untype_modtype_declaration mdecl = + match mdecl with + Tmodtype_abstract -> Pmodtype_abstract + | Tmodtype_manifest mtype -> Pmodtype_manifest (untype_module_type mtype) + +and untype_class_description cd = + { + pci_virt = cd.ci_virt; + pci_params = cd.ci_params; + pci_name = cd.ci_id_name; + pci_expr = untype_class_type cd.ci_expr; + pci_variance = cd.ci_variance; + pci_loc = cd.ci_loc; + } + +and untype_class_type_declaration cd = + { + pci_virt = cd.ci_virt; + pci_params = cd.ci_params; + pci_name = cd.ci_id_name; + pci_expr = untype_class_type cd.ci_expr; + pci_variance = cd.ci_variance; + pci_loc = cd.ci_loc; + } + +and untype_module_type mty = + let desc = match mty.mty_desc with + Tmty_ident (path, lid) -> Pmty_ident (lid) + | Tmty_signature sg -> Pmty_signature (untype_signature sg) + | Tmty_functor (id, name, mtype1, mtype2) -> + Pmty_functor (name, untype_module_type mtype1, + untype_module_type mtype2) + | Tmty_with (mtype, list) -> + Pmty_with (untype_module_type mtype, + List.map (fun (path, lid, withc) -> + lid, untype_with_constraint withc + ) list) + | Tmty_typeof mexpr -> + Pmty_typeof (untype_module_expr mexpr) + in + { + pmty_desc = desc; + pmty_loc = mty.mty_loc; + } + +and untype_with_constraint cstr = + match cstr with + Twith_type decl -> Pwith_type (untype_type_declaration decl) + | Twith_module (path, lid) -> Pwith_module (lid) + | Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl) + | Twith_modsubst (path, lid) -> Pwith_modsubst (lid) + +and untype_module_expr mexpr = + match mexpr.mod_desc with + Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> + untype_module_expr m + | _ -> + let desc = match mexpr.mod_desc with + Tmod_ident (p, lid) -> Pmod_ident (lid) + | Tmod_structure st -> Pmod_structure (untype_structure st) + | Tmod_functor (id, name, mtype, mexpr) -> + Pmod_functor (name, untype_module_type mtype, + untype_module_expr mexpr) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (untype_module_expr mexpr, + untype_module_type mtype) + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) -> + assert false + | Tmod_unpack (exp, pack) -> + Pmod_unpack (untype_expression exp) + (* TODO , untype_package_type pack) *) + + in + { + pmod_desc = desc; + pmod_loc = mexpr.mod_loc; + } + +and untype_class_expr cexpr = + let desc = match cexpr.cl_desc with + | Tcl_constraint ( { cl_desc = Tcl_ident (path, lid, tyl) }, None, _, _, _ ) -> + Pcl_constr (lid, + List.map untype_core_type tyl) + | Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr) + + | Tcl_fun (label, pat, pv, cl, partial) -> + Pcl_fun (label, None, untype_pattern pat, untype_class_expr cl) + + | Tcl_apply (cl, args) -> + Pcl_apply (untype_class_expr cl, + List.fold_right (fun (label, expo, _) list -> + match expo with + None -> list + | Some exp -> (label, untype_expression exp) :: list + ) args []) + + | Tcl_let (rec_flat, bindings, ivars, cl) -> + Pcl_let (rec_flat, + List.map (fun (pat, exp) -> + (untype_pattern pat, untype_expression exp)) bindings, + untype_class_expr cl) + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + Pcl_constraint (untype_class_expr cl, untype_class_type clty) + + | Tcl_ident _ -> assert false + | Tcl_constraint (_, None, _, _, _) -> assert false + in + { pcl_desc = desc; + pcl_loc = cexpr.cl_loc; + } + +and untype_class_type ct = + let desc = match ct.cltyp_desc with + Tcty_signature csg -> Pcty_signature (untype_class_signature csg) + | Tcty_constr (path, lid, list) -> + Pcty_constr (lid, List.map untype_core_type list) + | Tcty_fun (label, ct, cl) -> + Pcty_fun (label, untype_core_type ct, untype_class_type cl) + in + { pcty_desc = desc; + pcty_loc = ct.cltyp_loc } + +and untype_class_signature cs = + { + pcsig_self = untype_core_type cs.csig_self; + pcsig_fields = List.map untype_class_type_field cs.csig_fields; + pcsig_loc = cs.csig_loc; + } + +and untype_class_type_field ctf = + let desc = match ctf.ctf_desc with + Tctf_inher ct -> Pctf_inher (untype_class_type ct) + | Tctf_val (s, mut, virt, ct) -> + Pctf_val (s, mut, virt, untype_core_type ct) + | Tctf_virt (s, priv, ct) -> + Pctf_virt (s, priv, untype_core_type ct) + | Tctf_meth (s, priv, ct) -> + Pctf_meth (s, priv, untype_core_type ct) + | Tctf_cstr (ct1, ct2) -> + Pctf_cstr (untype_core_type ct1, untype_core_type ct2) + in + { + pctf_desc = desc; + pctf_loc = ctf.ctf_loc; + } + +and untype_core_type ct = + let desc = match ct.ctyp_desc with + Ttyp_any -> Ptyp_any + | Ttyp_var s -> Ptyp_var s + | Ttyp_arrow (label, ct1, ct2) -> + Ptyp_arrow (label, untype_core_type ct1, untype_core_type ct2) + | Ttyp_tuple list -> Ptyp_tuple (List.map untype_core_type list) + | Ttyp_constr (path, lid, list) -> + Ptyp_constr (lid, + List.map untype_core_type list) + | Ttyp_object list -> + Ptyp_object (List.map untype_core_field_type list) + | Ttyp_class (path, lid, list, labels) -> + Ptyp_class (lid, + List.map untype_core_type list, labels) + | Ttyp_alias (ct, s) -> + Ptyp_alias (untype_core_type ct, s) + | Ttyp_variant (list, bool, labels) -> + Ptyp_variant (List.map untype_row_field list, bool, labels) + | Ttyp_poly (list, ct) -> Ptyp_poly (list, untype_core_type ct) + | Ttyp_package pack -> Ptyp_package (untype_package_type pack) + in + { ptyp_desc = desc; ptyp_loc = ct.ctyp_loc } + +and untype_core_field_type cft = + { pfield_desc = (match cft.field_desc with + Tcfield_var -> Pfield_var + | Tcfield (s, ct) -> Pfield (s, untype_core_type ct)); + pfield_loc = cft.field_loc; } + +and untype_class_structure cs = + { pcstr_pat = untype_pattern cs.cstr_pat; + pcstr_fields = List.map untype_class_field cs.cstr_fields; + } + +and untype_row_field rf = + match rf with + Ttag (label, bool, list) -> + Rtag (label, bool, List.map untype_core_type list) + | Tinherit ct -> Rinherit (untype_core_type ct) + +and untype_class_field cf = + let desc = match cf.cf_desc with + Tcf_inher (ovf, cl, super, _vals, _meths) -> + Pcf_inher (ovf, untype_class_expr cl, super) + | Tcf_constr (cty, cty') -> + Pcf_constr (untype_core_type cty, untype_core_type cty') + | Tcf_val (lab, name, mut, _, Tcfk_virtual cty, override) -> + Pcf_valvirt (name, mut, untype_core_type cty) + | Tcf_val (lab, name, mut, _, Tcfk_concrete exp, override) -> + Pcf_val (name, mut, + (if override then Override else Fresh), + untype_expression exp) + | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> + Pcf_virt (name, priv, untype_core_type cty) + | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> + Pcf_meth (name, priv, + (if override then Override else Fresh), + untype_expression exp) +(* | Tcf_let (rec_flag, bindings, _) -> + Pcf_let (rec_flag, List.map (fun (pat, exp) -> + untype_pattern pat, untype_expression exp) bindings) +*) + | Tcf_init exp -> Pcf_init (untype_expression exp) + in + { pcf_desc = desc; pcf_loc = cf.cf_loc } diff --git a/tools/untypeast.mli b/tools/untypeast.mli new file mode 100644 index 0000000000..0e0805360e --- /dev/null +++ b/tools/untypeast.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +val untype_structure : Typedtree.structure -> Parsetree.structure +val untype_signature : Typedtree.signature -> Parsetree.signature + +val lident_of_path : Path.t -> Longident.t diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 38520a91e5..a8eed6b006 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -33,10 +33,10 @@ module type OBJ = module type EVALPATH = sig - type value - val eval_path: Path.t -> value + type valu + val eval_path: Path.t -> valu exception Error - val same_value: value -> value -> bool + val same_value: valu -> valu -> bool end module type S = @@ -52,7 +52,7 @@ module type S = Env.t -> t -> type_expr -> Outcometree.out_value end -module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct +module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct type t = O.t @@ -156,10 +156,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct let tree_of_constr = tree_of_qualified - (fun lid env -> (Env.lookup_constructor lid env).cstr_res) + (fun lid env -> (snd (Env.lookup_constructor lid env)).cstr_res) and tree_of_label = - tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res) + tree_of_qualified (fun lid env -> (snd (Env.lookup_label lid env)).lbl_res) (* An abstract type *) @@ -249,10 +249,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct else Cstr_constant(O.obj obj) in let (constr_name, constr_args,ret_type) = Datarepr.find_constr_by_tag tag constr_list in - let type_params = + let type_params = match ret_type with - Some t -> - begin match (Ctype.repr t).desc with + Some t -> + begin match (Ctype.repr t).desc with Tconstr (_,params,_) -> params | _ -> assert false end @@ -265,7 +265,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct 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 + (Ident.name 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 @@ -279,7 +279,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct ty_list with Ctype.Cannot_apply -> abstract_type in - let lid = tree_of_label env path lbl_name in + let lid = tree_of_label env path (Ident.name lbl_name) in let v = tree_of_val (depth - 1) (O.field obj pos) ty_arg @@ -352,7 +352,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct try (* Attempt to recover the constructor description for the exn from its name *) - let cstr = Env.lookup_constructor lid env in + let cstr = snd (Env.lookup_constructor lid env) in let path = match cstr.cstr_tag with Cstr_exception (p, _) -> p | _ -> raise Not_found in diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli index 6522cccdb0..a98ef3d1c0 100644 --- a/toplevel/genprintval.mli +++ b/toplevel/genprintval.mli @@ -29,10 +29,10 @@ module type OBJ = module type EVALPATH = sig - type value - val eval_path: Path.t -> value + type valu + val eval_path: Path.t -> valu exception Error - val same_value: value -> value -> bool + val same_value: valu -> valu -> bool end module type S = @@ -48,5 +48,5 @@ module type S = Env.t -> t -> type_expr -> Outcometree.out_value end -module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) : +module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) : (S with type t = O.t) diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 99a2cf0ac2..38b34ca416 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -41,6 +41,16 @@ let dir_directory s = let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) +(* To remove a directory from the load path *) +let dir_remove_directory s = + let d = expand_directory Config.standard_library Config.ocaml_library s in + Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path; + Dll.remove_path [d] + +let _ = + Hashtbl.add directive_table "remove_directory" + (Directive_string dir_remove_directory) + (* To change the current directory *) let dir_cd s = Sys.chdir s diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli index 11aa9b851b..266efccfef 100644 --- a/toplevel/topdirs.mli +++ b/toplevel/topdirs.mli @@ -18,6 +18,7 @@ open Format val dir_quit : unit -> unit val dir_directory : string -> unit +val dir_remove_directory : string -> unit val dir_cd : string -> unit val dir_load : formatter -> string -> unit val dir_use : formatter -> string -> unit diff --git a/toplevel/toplevellib.mllib b/toplevel/toplevellib.mllib index eb459a906d..886d1d2c82 100644 --- a/toplevel/toplevellib.mllib +++ b/toplevel/toplevellib.mllib @@ -4,9 +4,11 @@ Misc Tbl Config Clflags Terminfo Ccomp Warnings Consistbl Location Longident Syntaxerr Parser Lexer Parse Printast -Unused_var Ident Path Primitive Types -Btype Oprint Subst Predef Datarepr Env -Typedtree Ctype Printtyp Includeclass Mtype Includecore +Ident Path Primitive Types +Btype Oprint Subst Predef Datarepr +Cmi_format Env +Typedtree +Cmt_format Ctype Printtyp Includeclass Mtype Includecore Includemod Parmatch Typetexp Stypes Typecore Typedecl Typeclass Typemod diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 6bf39a29de..fbeed51aa4 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -66,7 +66,7 @@ let rec eval_path = function (* To print values *) module EvalPath = struct - type value = Obj.t + type valu = Obj.t exception Error let eval_path p = try eval_path p with Symtable.Error _ -> raise Error let same_value v1 v2 = (v1 == v2) @@ -150,7 +150,7 @@ let load_lambda ppf lam = (* Print the outcome of an evaluation *) let rec pr_item env = function - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> let tree = Printtyp.tree_of_value_description id decl in let valopt = match decl.val_kind with @@ -163,24 +163,24 @@ let rec pr_item env = function Some v in Some (tree, valopt, rem) - | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> + | Sig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> pr_item env rem - | Tsig_type(id, decl, rs) :: rem -> + | Sig_type(id, decl, rs) :: rem -> let tree = Printtyp.tree_of_type_declaration id decl rs in Some (tree, None, rem) - | Tsig_exception(id, decl) :: rem -> + | Sig_exception(id, decl) :: rem -> let tree = Printtyp.tree_of_exception_declaration id decl in Some (tree, None, rem) - | Tsig_module(id, mty, rs) :: rem -> + | Sig_module(id, mty, rs) :: rem -> let tree = Printtyp.tree_of_module id mty rs in Some (tree, None, rem) - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> let tree = Printtyp.tree_of_modtype_declaration id decl in Some (tree, None, rem) - | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> + | Sig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_class_declaration id decl rs in Some (tree, None, rem) - | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_cltype_declaration id decl rs in Some (tree, None, rem) | _ -> None @@ -218,8 +218,9 @@ let execute_phrase print_outcome ppf phr = | Ptop_def sstr -> let oldenv = !toplevel_env in Typecore.reset_delayed_checks (); - let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none - in + let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in + let sg' = Typemod.simplify_signature sg in + ignore (Includemod.signatures oldenv sg sg'); Typecore.force_delayed_checks (); let lam = Translmod.transl_toplevel_definition str in Warnings.check_fatal (); @@ -230,14 +231,13 @@ let execute_phrase print_outcome ppf phr = match res with | Result v -> if print_outcome then - match str with - | [Tstr_eval exp] -> + match str.str_items with + | [ { str_desc = Tstr_eval exp }] -> let outv = outval_of_value newenv v exp.exp_type in let ty = Printtyp.tree_of_type_scheme exp.exp_type in Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (item_list newenv - (Typemod.simplify_signature sg)) + | _ -> Ophr_signature (item_list newenv sg') else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; @@ -423,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 diff --git a/typing/btype.ml b/typing/btype.ml index 91b8520b87..0e864e00d5 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -57,6 +57,8 @@ let newmarkedgenvar () = let is_Tvar = function {desc=Tvar _} -> true | _ -> false let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false +let dummy_method = "*dummy method*" + (**** Representative of a type ****) let rec field_kind_repr = @@ -124,6 +126,14 @@ let rec row_more row = | {desc=Tvariant row'} -> row_more row' | ty -> ty +let row_fixed row = + let row = row_repr row in + row.row_fixed || + match (repr row.row_more).desc with + Tvar _ | Tnil -> false + | Tunivar _ | Tconstr _ -> true + | _ -> assert false + let static_row row = let row = row_repr row in row.row_closed && @@ -256,8 +266,8 @@ let rec norm_univar ty = | Ttuple (ty :: _) -> norm_univar ty | _ -> assert false -let rec copy_type_desc f = function - Tvar _ -> Tvar None (* forget the name *) +let rec copy_type_desc ?(keep_names=false) f = function + Tvar _ as ty -> if keep_names then ty else Tvar None | 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) @@ -270,7 +280,7 @@ let rec copy_type_desc f = function | Tnil -> Tnil | Tlink ty -> copy_type_desc f ty.desc | Tsubst ty -> assert false - | Tunivar _ as ty -> ty (* keep the name *) + | Tunivar _ as ty -> ty (* always keep the name *) | Tpoly (ty, tyl) -> let tyl = List.map (fun x -> norm_univar (f x)) tyl in Tpoly (f ty, tyl) @@ -352,11 +362,11 @@ let unmark_class_signature sign = let rec unmark_class_type = function - Tcty_constr (p, tyl, cty) -> + Cty_constr (p, tyl, cty) -> List.iter unmark_type tyl; unmark_class_type cty - | Tcty_signature sign -> + | Cty_signature sign -> unmark_class_signature sign - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> unmark_type ty; unmark_class_type cty diff --git a/typing/btype.mli b/typing/btype.mli index e2e4c9d6db..ddb34a8fb7 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -43,6 +43,7 @@ val newmarkedgenvar: unit -> type_expr val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool +val dummy_method: label val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) @@ -63,6 +64,8 @@ val row_field: label -> row_desc -> row_field (* Return the canonical representative of a row field *) val row_more: row_desc -> type_expr (* Return the extension variable of the row *) +val row_fixed: row_desc -> bool + (* Return whether the row should be treated as fixed or not *) val static_row: row_desc -> bool (* Return whether the row is static or not *) val hash_variant: label -> int @@ -85,7 +88,8 @@ val iter_row: (type_expr -> unit) -> row_desc -> unit val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit (* Iteration on types in an abbreviation list *) -val copy_type_desc: (type_expr -> type_expr) -> type_desc -> type_desc +val copy_type_desc: + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc (* Copy on types *) val copy_row: (type_expr -> type_expr) -> diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml new file mode 100644 index 0000000000..d40b1977d0 --- /dev/null +++ b/typing/cmi_format.ml @@ -0,0 +1,93 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type pers_flags = Rectypes + +type error = + Not_an_interface of string + | Wrong_version_interface of string * string + | Corrupted_interface of string + +exception Error of error + +type cmi_infos = { + cmi_name : string; + cmi_sign : Types.signature_item list; + cmi_crcs : (string * Digest.t) list; + cmi_flags : pers_flags list; +} + +let input_cmi ic = + let (name, sign) = input_value ic in + let crcs = input_value ic in + let flags = input_value ic in + { + cmi_name = name; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags; + } + +let read_cmi filename = + let ic = open_in_bin filename in + try + let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in + if buffer <> Config.cmi_magic_number then begin + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len then + begin + let msg = + if buffer < Config.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 cmi = input_cmi ic in + close_in ic; + cmi + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface(filename))) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = +(* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + output_value oc (cmi.cmi_name, cmi.cmi_sign); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, crc) :: cmi.cmi_crcs in + output_value oc crcs; + output_value oc cmi.cmi_flags; + crc + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%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@ %a" + Location.print_filename filename diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli new file mode 100644 index 0000000000..2d6fdec6bb --- /dev/null +++ b/typing/cmi_format.mli @@ -0,0 +1,42 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type pers_flags = Rectypes + +type cmi_infos = { + cmi_name : string; + cmi_sign : Types.signature_item list; + cmi_crcs : (string * Digest.t) list; + cmi_flags : pers_flags list; +} + +(* write the magic + the cmi information *) +val output_cmi : string -> out_channel -> cmi_infos -> Digest.t + +(* read the cmi information (the magic is supposed to have already been read) *) +val input_cmi : in_channel -> cmi_infos + +(* read a cmi from a filename, checking the magic *) +val read_cmi : string -> cmi_infos + +(* Error report *) + +type error = + Not_an_interface of string + | Wrong_version_interface of string * string + | Corrupted_interface of string + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml new file mode 100644 index 0000000000..af4b75f0ef --- /dev/null +++ b/typing/cmt_format.ml @@ -0,0 +1,1036 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Cmi_format +open Typedtree + +(* Note that in Typerex, there is an awful hack to save a cmt file + together with the interface file that was generated by ocaml (this + is because the installed version of ocaml might differ from the one + integrated in Typerex). +*) + + + +let read_magic_number ic = + let len_magic_number = String.length Config.cmt_magic_number in + let magic_number = String.create len_magic_number in + really_input ic magic_number 0 len_magic_number; + magic_number + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = +| Partial_structure of structure +| Partial_structure_item of structure_item +| Partial_expression of expression +| Partial_pattern of pattern +| Partial_class_expr of class_expr +| Partial_signature of signature +| Partial_signature_item of signature_item +| Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : Digest.t option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + + + + + + + + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +(* Re-introduce sharing after clearing environments *) +let env_hcons = Hashtbl.create 133 +let keep_only_summary env = + let new_env = Env.keep_only_summary env in + try + Hashtbl.find env_hcons new_env + with Not_found -> + Hashtbl.add env_hcons new_env new_env; + new_env +let clear_env_hcons () = Hashtbl.clear env_hcons + + + + +module TypedtreeMap : sig + + open Asttypes + open Typedtree + + module type MapArgument = sig + val enter_structure : structure -> structure + val enter_value_description : value_description -> value_description + val enter_type_declaration : type_declaration -> type_declaration + val enter_exception_declaration : + exception_declaration -> exception_declaration + val enter_pattern : pattern -> pattern + val enter_expression : expression -> expression + val enter_package_type : package_type -> package_type + val enter_signature : signature -> signature + val enter_signature_item : signature_item -> signature_item + val enter_modtype_declaration : modtype_declaration -> modtype_declaration + val enter_module_type : module_type -> module_type + val enter_module_expr : module_expr -> module_expr + val enter_with_constraint : with_constraint -> with_constraint + val enter_class_expr : class_expr -> class_expr + val enter_class_signature : class_signature -> class_signature + val enter_class_description : class_description -> class_description + val enter_class_type_declaration : + class_type_declaration -> class_type_declaration + val enter_class_infos : 'a class_infos -> 'a class_infos + val enter_class_type : class_type -> class_type + val enter_class_type_field : class_type_field -> class_type_field + val enter_core_type : core_type -> core_type + val enter_core_field_type : core_field_type -> core_field_type + val enter_class_structure : class_structure -> class_structure + val enter_class_field : class_field -> class_field + val enter_structure_item : structure_item -> structure_item + + val leave_structure : structure -> structure + val leave_value_description : value_description -> value_description + val leave_type_declaration : type_declaration -> type_declaration + val leave_exception_declaration : + exception_declaration -> exception_declaration + val leave_pattern : pattern -> pattern + val leave_expression : expression -> expression + val leave_package_type : package_type -> package_type + val leave_signature : signature -> signature + val leave_signature_item : signature_item -> signature_item + val leave_modtype_declaration : modtype_declaration -> modtype_declaration + val leave_module_type : module_type -> module_type + val leave_module_expr : module_expr -> module_expr + val leave_with_constraint : with_constraint -> with_constraint + val leave_class_expr : class_expr -> class_expr + val leave_class_signature : class_signature -> class_signature + val leave_class_description : class_description -> class_description + val leave_class_type_declaration : + class_type_declaration -> class_type_declaration + val leave_class_infos : 'a class_infos -> 'a class_infos + val leave_class_type : class_type -> class_type + val leave_class_type_field : class_type_field -> class_type_field + val leave_core_type : core_type -> core_type + val leave_core_field_type : core_field_type -> core_field_type + val leave_class_structure : class_structure -> class_structure + val leave_class_field : class_field -> class_field + val leave_structure_item : structure_item -> structure_item + + end + + module MakeMap : + functor + (Iter : MapArgument) -> + sig + val map_structure : structure -> structure + val map_pattern : pattern -> pattern + val map_structure_item : structure_item -> structure_item + val map_expression : expression -> expression + val map_class_expr : class_expr -> class_expr + + val map_signature : signature -> signature + val map_signature_item : signature_item -> signature_item + val map_module_type : module_type -> module_type + end + + module DefaultMapArgument : MapArgument + +end = struct + + open Asttypes + open Typedtree + + module type MapArgument = sig + val enter_structure : structure -> structure + val enter_value_description : value_description -> value_description + val enter_type_declaration : type_declaration -> type_declaration + val enter_exception_declaration : + exception_declaration -> exception_declaration + val enter_pattern : pattern -> pattern + val enter_expression : expression -> expression + val enter_package_type : package_type -> package_type + val enter_signature : signature -> signature + val enter_signature_item : signature_item -> signature_item + val enter_modtype_declaration : modtype_declaration -> modtype_declaration + val enter_module_type : module_type -> module_type + val enter_module_expr : module_expr -> module_expr + val enter_with_constraint : with_constraint -> with_constraint + val enter_class_expr : class_expr -> class_expr + val enter_class_signature : class_signature -> class_signature + val enter_class_description : class_description -> class_description + val enter_class_type_declaration : + class_type_declaration -> class_type_declaration + val enter_class_infos : 'a class_infos -> 'a class_infos + val enter_class_type : class_type -> class_type + val enter_class_type_field : class_type_field -> class_type_field + val enter_core_type : core_type -> core_type + val enter_core_field_type : core_field_type -> core_field_type + val enter_class_structure : class_structure -> class_structure + val enter_class_field : class_field -> class_field + val enter_structure_item : structure_item -> structure_item + + val leave_structure : structure -> structure + val leave_value_description : value_description -> value_description + val leave_type_declaration : type_declaration -> type_declaration + val leave_exception_declaration : + exception_declaration -> exception_declaration + val leave_pattern : pattern -> pattern + val leave_expression : expression -> expression + val leave_package_type : package_type -> package_type + val leave_signature : signature -> signature + val leave_signature_item : signature_item -> signature_item + val leave_modtype_declaration : modtype_declaration -> modtype_declaration + val leave_module_type : module_type -> module_type + val leave_module_expr : module_expr -> module_expr + val leave_with_constraint : with_constraint -> with_constraint + val leave_class_expr : class_expr -> class_expr + val leave_class_signature : class_signature -> class_signature + val leave_class_description : class_description -> class_description + val leave_class_type_declaration : + class_type_declaration -> class_type_declaration + val leave_class_infos : 'a class_infos -> 'a class_infos + val leave_class_type : class_type -> class_type + val leave_class_type_field : class_type_field -> class_type_field + val leave_core_type : core_type -> core_type + val leave_core_field_type : core_field_type -> core_field_type + val leave_class_structure : class_structure -> class_structure + val leave_class_field : class_field -> class_field + val leave_structure_item : structure_item -> structure_item + + end + + + module MakeMap(Map : MapArgument) = struct + + let may_map f v = + match v with + None -> v + | Some x -> Some (f x) + + + open Misc + open Asttypes + + let rec map_structure str = + let str = Map.enter_structure str in + let str_items = List.map map_structure_item str.str_items in + Map.leave_structure { str with str_items = str_items } + + and map_binding (pat, exp) = (map_pattern pat, map_expression exp) + + and map_bindings rec_flag list = + List.map map_binding list + +(*>JOCAML *) + and map_joinautomaton d = d (* TODO *) + + and map_joinautomata ds = List.map map_joinautomaton ds + +(*<JOCAML *) + and map_structure_item item = + let item = Map.enter_structure_item item in + let str_desc = + match item.str_desc with + Tstr_eval exp -> Tstr_eval (map_expression exp) + | Tstr_value (rec_flag, list) -> + Tstr_value (rec_flag, map_bindings rec_flag list) + | Tstr_primitive (id, name, v) -> + Tstr_primitive (id, name, map_value_description v) + | Tstr_type list -> + Tstr_type (List.map ( + fun (id, name, decl) -> + (id, name, map_type_declaration decl) ) list) + | Tstr_exception (id, name, decl) -> + Tstr_exception (id, name, map_exception_declaration decl) + | Tstr_exn_rebind (id, name, path, lid) -> + Tstr_exn_rebind (id, name, path, lid) + | Tstr_module (id, name, mexpr) -> + Tstr_module (id, name, map_module_expr mexpr) + | Tstr_recmodule list -> + let list = + List.map (fun (id, name, mtype, mexpr) -> + (id, name, map_module_type mtype, map_module_expr mexpr) + ) list + in + Tstr_recmodule list + | Tstr_modtype (id, name, mtype) -> + Tstr_modtype (id, name, map_module_type mtype) + | Tstr_open (path, lid) -> Tstr_open (path, lid) + | Tstr_class list -> + let list = + List.map (fun (ci, string_list, virtual_flag) -> + let ci = Map.enter_class_infos ci in + let ci_expr = map_class_expr ci.ci_expr in + (Map.leave_class_infos { ci with ci_expr = ci_expr}, + string_list, virtual_flag) + ) list + in + Tstr_class list + | Tstr_class_type list -> + let list = List.map (fun (id, name, ct) -> + let ct = Map.enter_class_infos ct in + let ci_expr = map_class_type ct.ci_expr in + (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr}) + ) list in + Tstr_class_type list + | Tstr_include (mexpr, idents) -> + Tstr_include (map_module_expr mexpr, idents) +(*> JOCAML *) + | Tstr_def d -> Tstr_def (map_joinautomata d) + | Tstr_loc _ -> assert false + | Tstr_exn_global (path,loc) -> Tstr_exn_global (path,loc) +(*< JOCAML *) + in + Map.leave_structure_item { item with str_desc = str_desc} + + and map_value_description v = + let v = Map.enter_value_description v in + let val_desc = map_core_type v.val_desc in + Map.leave_value_description { v with val_desc = val_desc } + + and map_type_declaration decl = + let decl = Map.enter_type_declaration decl in + let typ_cstrs = List.map (fun (ct1, ct2, loc) -> + (map_core_type ct1, + map_core_type ct2, + loc) + ) decl.typ_cstrs in + let typ_kind = match decl.typ_kind with + Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> + let list = List.map (fun (s, name, cts, loc) -> + (s, name, List.map map_core_type cts, loc) + ) list in + Ttype_variant list + | Ttype_record list -> + let list = + List.map (fun (s, name, mut, ct, loc) -> + (s, name, mut, map_core_type ct, loc) + ) list in + Ttype_record list + in + let typ_manifest = + match decl.typ_manifest with + None -> None + | Some ct -> Some (map_core_type ct) + in + Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs; + typ_kind = typ_kind; typ_manifest = typ_manifest } + + and map_exception_declaration decl = + let decl = Map.enter_exception_declaration decl in + let exn_params = List.map map_core_type decl.exn_params in + let decl = { exn_params = exn_params; + exn_exn = decl.exn_exn; + exn_loc = decl.exn_loc } in + Map.leave_exception_declaration decl; + + and map_pattern pat = + let pat = Map.enter_pattern pat in + let pat_desc = + match pat.pat_desc with + | Tpat_alias (pat1, p, text) -> + let pat1 = map_pattern pat1 in + Tpat_alias (pat1, p, text) + | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) + | Tpat_construct (path, lid, cstr_decl, args, arity) -> + Tpat_construct (path, lid, cstr_decl, + List.map map_pattern args, arity) + | Tpat_variant (label, pato, rowo) -> + let pato = match pato with + None -> pato + | Some pat -> Some (map_pattern pat) + in + Tpat_variant (label, pato, rowo) + | Tpat_record (list, closed) -> + Tpat_record (List.map (fun (path, lid, lab_desc, pat) -> + (path, lid, lab_desc, map_pattern pat) ) list, closed) + | Tpat_array list -> Tpat_array (List.map map_pattern list) + | Tpat_or (p1, p2, rowo) -> + Tpat_or (map_pattern p1, map_pattern p2, rowo) + | Tpat_lazy p -> Tpat_lazy (map_pattern p) + | Tpat_constant _ + | Tpat_any + | Tpat_var _ -> pat.pat_desc + + in + let pat_extra = List.map map_pat_extra pat.pat_extra in + Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } + + and map_pat_extra pat_extra = + match pat_extra with + | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc) + | (Tpat_type _ | Tpat_unpack), _ -> pat_extra + + and map_expression exp = + let exp = Map.enter_expression exp in + let exp_desc = + match exp.exp_desc with + Texp_ident (_, _, _) + | Texp_constant _ -> exp.exp_desc + | Texp_let (rec_flag, list, exp) -> + Texp_let (rec_flag, + map_bindings rec_flag list, + map_expression exp) + | Texp_function (label, cases, partial) -> + Texp_function (label, map_bindings Nonrecursive cases, partial) + | Texp_apply (exp, list) -> + Texp_apply (map_expression exp, + List.map (fun (label, expo, optional) -> + let expo = + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + (label, expo, optional) + ) list ) + | Texp_match (exp, list, partial) -> + Texp_match ( + map_expression exp, + map_bindings Nonrecursive list, + partial + ) + | Texp_try (exp, list) -> + Texp_try ( + map_expression exp, + map_bindings Nonrecursive list + ) + | Texp_tuple list -> + Texp_tuple (List.map map_expression list) + | Texp_construct (path, lid, cstr_desc, args, arity) -> + Texp_construct (path, lid, cstr_desc, + List.map map_expression args, arity ) + | Texp_variant (label, expo) -> + let expo =match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_variant (label, expo) + | Texp_record (list, expo) -> + let list = + List.map (fun (path, lid, lab_desc, exp) -> + (path, lid, lab_desc, map_expression exp) + ) list in + let expo = match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_record (list, expo) + | Texp_field (exp, path, lid, label) -> + Texp_field (map_expression exp, path, lid, label) + | Texp_setfield (exp1, path, lid, label, exp2) -> + Texp_setfield ( + map_expression exp1, + path, lid, + label, + map_expression exp2) + | Texp_array list -> + Texp_array (List.map map_expression list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + map_expression exp1, + map_expression exp2, + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + map_expression exp1, + map_expression exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + map_expression exp1, + map_expression exp2 + ) + | Texp_for (id, name, exp1, exp2, dir, exp3) -> + Texp_for ( + id, name, + map_expression exp1, + map_expression exp2, + dir, + map_expression exp3 + ) + | Texp_when (exp1, exp2) -> + Texp_when ( + map_expression exp1, + map_expression exp2 + ) + | Texp_send (exp, meth, expo) -> + Texp_send (map_expression exp, meth, may_map map_expression expo) + | Texp_new (path, lid, cl_decl) -> exp.exp_desc + | Texp_instvar (_, path, _) -> exp.exp_desc + | Texp_setinstvar (path, lid, path2, exp) -> + Texp_setinstvar (path, lid, path2, map_expression exp) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (fun (path, lid, exp) -> + (path, lid, map_expression exp) + ) list + ) + | Texp_letmodule (id, name, mexpr, exp) -> + Texp_letmodule ( + id, name, + map_module_expr mexpr, + map_expression exp + ) + | Texp_assert exp -> Texp_assert (map_expression exp) + | Texp_assertfalse -> exp.exp_desc + | Texp_lazy exp -> Texp_lazy (map_expression exp) + | Texp_object (cl, string_list) -> + Texp_object (map_class_structure cl, string_list) + | Texp_pack (mexpr) -> + Texp_pack (map_module_expr mexpr) +(*>JOCAML *) + | Texp_asyncsend (e1,e2) -> + Texp_asyncsend (map_expression e1,map_expression e2) + |Texp_spawn e -> + Texp_spawn (map_expression e) + |Texp_par (e1, e2) -> + Texp_par (map_expression e1,map_expression e2) + |Texp_null -> + Texp_null + | Texp_reply (e, id) -> + Texp_reply (map_expression e,id) + |Texp_def (d, e) -> + Texp_def(map_joinautomata d,map_expression e) + |Texp_loc (_, _) -> assert false +(*<JOCAML *) + in + let exp_extra = List.map map_exp_extra exp.exp_extra in + Map.leave_expression { + exp with + exp_desc = exp_desc; + exp_extra = exp_extra } + + and map_exp_extra exp_extra = + let loc = snd exp_extra in + match fst exp_extra with + | Texp_constraint (Some ct, None) -> + Texp_constraint (Some (map_core_type ct), None), loc + | Texp_constraint (None, Some ct) -> + Texp_constraint (None, Some (map_core_type ct)), loc + | Texp_constraint (Some ct1, Some ct2) -> + Texp_constraint (Some (map_core_type ct1), + Some (map_core_type ct2)), loc + | Texp_poly (Some ct) -> + Texp_poly (Some ( map_core_type ct )), loc + | Texp_newtype _ + | Texp_constraint (None, None) + | Texp_open _ + | Texp_poly None -> exp_extra + + + and map_package_type pack = + let pack = Map.enter_package_type pack in + let pack_fields = List.map ( + fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in + Map.leave_package_type { pack with pack_fields = pack_fields } + + and map_signature sg = + let sg = Map.enter_signature sg in + let sig_items = List.map map_signature_item sg.sig_items in + Map.leave_signature { sg with sig_items = sig_items } + + and map_signature_item item = + let item = Map.enter_signature_item item in + let sig_desc = + match item.sig_desc with + Tsig_value (id, name, v) -> + Tsig_value (id, name, map_value_description v) + | Tsig_type list -> Tsig_type ( + List.map (fun (id, name, decl) -> + (id, name, map_type_declaration decl) + ) list + ) + | Tsig_exception (id, name, decl) -> + Tsig_exception (id, name, map_exception_declaration decl) + | Tsig_module (id, name, mtype) -> + Tsig_module (id, name, map_module_type mtype) + | Tsig_recmodule list -> + Tsig_recmodule (List.map ( + fun (id, name, mtype) -> + (id, name, map_module_type mtype) ) list) + | Tsig_modtype (id, name, mdecl) -> + Tsig_modtype (id, name, map_modtype_declaration mdecl) + | Tsig_open (path, lid) -> item.sig_desc + | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) + | Tsig_class list -> Tsig_class (List.map map_class_description list) + | Tsig_class_type list -> + Tsig_class_type (List.map map_class_type_declaration list) + in + Map.leave_signature_item { item with sig_desc = sig_desc } + + and map_modtype_declaration mdecl = + let mdecl = Map.enter_modtype_declaration mdecl in + let mdecl = + match mdecl with + Tmodtype_abstract -> Tmodtype_abstract + | Tmodtype_manifest mtype -> + Tmodtype_manifest (map_module_type mtype) + in + Map.leave_modtype_declaration mdecl + + + and map_class_description cd = + let cd = Map.enter_class_description cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_description { cd with ci_expr = ci_expr} + + and map_class_type_declaration cd = + let cd = Map.enter_class_type_declaration cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_type_declaration { cd with ci_expr = ci_expr } + + and map_module_type mty = + let mty = Map.enter_module_type mty in + let mty_desc = + match mty.mty_desc with + Tmty_ident (path, lid) -> mty.mty_desc + | Tmty_signature sg -> Tmty_signature (map_signature sg) + | Tmty_functor (id, name, mtype1, mtype2) -> + Tmty_functor (id, name, map_module_type mtype1, + map_module_type mtype2) + | Tmty_with (mtype, list) -> + Tmty_with (map_module_type mtype, + List.map (fun (path, lid, withc) -> + (path, lid, map_with_constraint withc) + ) list) + | Tmty_typeof mexpr -> + Tmty_typeof (map_module_expr mexpr) + in + Map.leave_module_type { mty with mty_desc = mty_desc} + + and map_with_constraint cstr = + let cstr = Map.enter_with_constraint cstr in + let cstr = + match cstr with + Twith_type decl -> Twith_type (map_type_declaration decl) + | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) + | Twith_module (path, lid) -> cstr + | Twith_modsubst (path, lid) -> cstr + in + Map.leave_with_constraint cstr + + and map_module_expr mexpr = + let mexpr = Map.enter_module_expr mexpr in + let mod_desc = + match mexpr.mod_desc with + Tmod_ident (p, lid) -> mexpr.mod_desc + | Tmod_structure st -> Tmod_structure (map_structure st) + | Tmod_functor (id, name, mtype, mexpr) -> + Tmod_functor (id, name, map_module_type mtype, + map_module_expr mexpr) + | Tmod_apply (mexp1, mexp2, coercion) -> + Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) + | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_implicit, coercion) + | Tmod_constraint (mexpr, mod_type, + Tmodtype_explicit mtype, coercion) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_explicit (map_module_type mtype), + coercion) + | Tmod_unpack (exp, mod_type) -> + Tmod_unpack (map_expression exp, mod_type) + in + Map.leave_module_expr { mexpr with mod_desc = mod_desc } + + and map_class_expr cexpr = + let cexpr = Map.enter_class_expr cexpr in + let cl_desc = + match cexpr.cl_desc with + | Tcl_constraint (cl, None, string_list1, string_list2, concr ) -> + Tcl_constraint (map_class_expr cl, None, string_list1, + string_list2, concr) + | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun (label, map_pattern pat, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) priv, + map_class_expr cl, partial) + + | Tcl_apply (cl, args) -> + Tcl_apply (map_class_expr cl, + List.map (fun (label, expo, optional) -> + (label, may_map map_expression expo, + optional) + ) args) + | Tcl_let (rec_flat, bindings, ivars, cl) -> + Tcl_let (rec_flat, map_bindings rec_flat bindings, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) ivars, + map_class_expr cl) + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + Tcl_constraint ( map_class_expr cl, + Some (map_class_type clty), vals, meths, concrs) + + | Tcl_ident (id, name, tyl) -> + Tcl_ident (id, name, List.map map_core_type tyl) + in + Map.leave_class_expr { cexpr with cl_desc = cl_desc } + + and map_class_type ct = + let ct = Map.enter_class_type ct in + let cltyp_desc = + match ct.cltyp_desc with + Tcty_signature csg -> Tcty_signature (map_class_signature csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr (path, lid, List.map map_core_type list) + | Tcty_fun (label, ct, cl) -> + Tcty_fun (label, map_core_type ct, map_class_type cl) + in + Map.leave_class_type { ct with cltyp_desc = cltyp_desc } + + and map_class_signature cs = + let cs = Map.enter_class_signature cs in + let csig_self = map_core_type cs.csig_self in + let csig_fields = List.map map_class_type_field cs.csig_fields in + Map.leave_class_signature { cs with + csig_self = csig_self; csig_fields = csig_fields } + + + and map_class_type_field ctf = + let ctf = Map.enter_class_type_field ctf in + let ctf_desc = + match ctf.ctf_desc with + Tctf_inher ct -> Tctf_inher (map_class_type ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, map_core_type ct) + | Tctf_virt (s, priv, ct) -> + Tctf_virt (s, priv, map_core_type ct) + | Tctf_meth (s, priv, ct) -> + Tctf_meth (s, priv, map_core_type ct) + | Tctf_cstr (ct1, ct2) -> + Tctf_cstr (map_core_type ct1, map_core_type ct2) + in + Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } + + and map_core_type ct = + let ct = Map.enter_core_type ct in + let ctyp_desc = + match ct.ctyp_desc with + Ttyp_any + | Ttyp_var _ -> ct.ctyp_desc + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map map_core_type list) + | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list) + | Ttyp_class (path, lid, list, labels) -> + Ttyp_class (path, lid, List.map map_core_type list, labels) + | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) + | Ttyp_variant (list, bool, labels) -> + Ttyp_variant (List.map map_row_field list, bool, labels) + | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) + | Ttyp_package pack -> Ttyp_package (map_package_type pack) + in + Map.leave_core_type { ct with ctyp_desc = ctyp_desc } + + and map_core_field_type cft = + let cft = Map.enter_core_field_type cft in + let field_desc = match cft.field_desc with + Tcfield_var -> Tcfield_var + | Tcfield (s, ct) -> Tcfield (s, map_core_type ct) + in + Map.leave_core_field_type { cft with field_desc = field_desc } + + and map_class_structure cs = + let cs = Map.enter_class_structure cs in + let cstr_pat = map_pattern cs.cstr_pat in + let cstr_fields = List.map map_class_field cs.cstr_fields in + Map.leave_class_structure { cs with cstr_pat = cstr_pat; + cstr_fields = cstr_fields } + + and map_row_field rf = + match rf with + Ttag (label, bool, list) -> + Ttag (label, bool, List.map map_core_type list) + | Tinherit ct -> Tinherit (map_core_type ct) + + and map_class_field cf = + let cf = Map.enter_class_field cf in + let cf_desc = + match cf.cf_desc with + Tcf_inher (ovf, cl, super, vals, meths) -> + Tcf_inher (ovf, map_class_expr cl, super, vals, meths) + | Tcf_constr (cty, cty') -> + Tcf_constr (map_core_type cty, map_core_type cty') + | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty), + override) + | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp), + override) + | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> + Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty), + override) + | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> + Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp), + override) + | Tcf_init exp -> Tcf_init (map_expression exp) + in + Map.leave_class_field { cf with cf_desc = cf_desc } + + end + +module DefaultMapArgument = struct + + let enter_structure t = t + let enter_value_description t = t + let enter_type_declaration t = t + let enter_exception_declaration t = t + let enter_pattern t = t + let enter_expression t = t + let enter_package_type t = t + let enter_signature t = t + let enter_signature_item t = t + let enter_modtype_declaration t = t + let enter_module_type t = t + let enter_module_expr t = t + let enter_with_constraint t = t + let enter_class_expr t = t + let enter_class_signature t = t + let enter_class_description t = t + let enter_class_type_declaration t = t + let enter_class_infos t = t + let enter_class_type t = t + let enter_class_type_field t = t + let enter_core_type t = t + let enter_core_field_type t = t + let enter_class_structure t = t + let enter_class_field t = t + let enter_structure_item t = t + + + let leave_structure t = t + let leave_value_description t = t + let leave_type_declaration t = t + let leave_exception_declaration t = t + let leave_pattern t = t + let leave_expression t = t + let leave_package_type t = t + let leave_signature t = t + let leave_signature_item t = t + let leave_modtype_declaration t = t + let leave_module_type t = t + let leave_module_expr t = t + let leave_with_constraint t = t + let leave_class_expr t = t + let leave_class_signature t = t + let leave_class_description t = t + let leave_class_type_declaration t = t + let leave_class_infos t = t + let leave_class_type t = t + let leave_class_type_field t = t + let leave_core_type t = t + let leave_core_field_type t = t + let leave_class_structure t = t + let leave_class_field t = t + let leave_structure_item t = t + + end + +end + +module ClearEnv = TypedtreeMap.MakeMap (struct + open TypedtreeMap + include DefaultMapArgument + + let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env } + let leave_expression e = + let exp_extra = List.map (function + (Texp_open (path, lloc, env), loc) -> + (Texp_open (path, lloc, keep_only_summary env), loc) + | exp_extra -> exp_extra) e.exp_extra in + { e with + exp_env = keep_only_summary e.exp_env; + exp_extra = exp_extra } + let leave_class_expr c = + { c with cl_env = keep_only_summary c.cl_env } + let leave_module_expr m = + { m with mod_env = keep_only_summary m.mod_env } + let leave_structure s = + { s with str_final_env = keep_only_summary s.str_final_env } + let leave_structure_item str = + { str with str_env = keep_only_summary str.str_env } + let leave_module_type m = + { m with mty_env = keep_only_summary m.mty_env } + let leave_signature s = + { s with sig_final_env = keep_only_summary s.sig_final_env } + let leave_signature_item s = + { s with sig_env = keep_only_summary s.sig_env } + let leave_core_type c = + { c with ctyp_env = keep_only_summary c.ctyp_env } + let leave_class_type c = + { c with cltyp_env = keep_only_summary c.cltyp_env } + +end) + +let rec clear_part p = match p with + | Partial_structure s -> Partial_structure (ClearEnv.map_structure s) + | Partial_structure_item s -> + Partial_structure_item (ClearEnv.map_structure_item s) + | Partial_expression e -> Partial_expression (ClearEnv.map_expression e) + | Partial_pattern p -> Partial_pattern (ClearEnv.map_pattern p) + | Partial_class_expr ce -> Partial_class_expr (ClearEnv.map_class_expr ce) + | Partial_signature s -> Partial_signature (ClearEnv.map_signature s) + | Partial_signature_item s -> + Partial_signature_item (ClearEnv.map_signature_item s) + | Partial_module_type s -> Partial_module_type (ClearEnv.map_module_type s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (ClearEnv.map_structure s) + | Interface s -> Interface (ClearEnv.map_signature s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + + + + +exception Error of error + +let input_cmt ic = (input_value ic : cmt_infos) + +let output_cmt oc cmt = + output_string oc Config.cmt_magic_number; + output_value oc (cmt : cmt_infos) + +let read filename = +(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) + let ic = open_in_bin filename in + try + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) + in + close_in ic; +(* Printf.fprintf stderr "Cmt_format.read done\n%!"; *) + cmi, cmt + with e -> + close_in ic; + raise e + +let string_of_file filename = + let ic = open_in filename in + let s = Misc.string_of_file ic in + close_in ic; + s + +let read_cmt filename = + match read filename with + _, None -> raise (Error (Not_a_typedtree filename)) + | _, Some cmt -> cmt + +let read_cmi filename = + match read filename with + None, _ -> + raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) + | Some cmi, _ -> cmi + +let saved_types = ref [] + +let add_saved_type b = saved_types := b :: !saved_types +let get_saved_types () = !saved_types +let set_saved_types l = saved_types := l + +let save_cmt filename modname binary_annots sourcefile initial_env sg = + if !Clflags.binary_annotations + && not !Clflags.print_types + && not !Clflags.dont_write_files + then begin + let imports = Env.imported_units () in + let oc = open_out_bin filename in + let this_crc = + match sg with + None -> None + | Some (sg) -> + let cmi = { + cmi_name = modname; + cmi_sign = sg; + cmi_flags = + if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; + cmi_crcs = imports; + } in + Some (output_cmi filename oc cmi) + in + let source_digest = Misc.may_map Digest.file sourcefile in + let cmt = { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_comments = Lexer.comments (); + cmt_args = Sys.argv; + cmt_sourcefile = sourcefile; + cmt_builddir = Sys.getcwd (); + cmt_loadpath = !Config.load_path; + cmt_source_digest = source_digest; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; + cmt_imports = List.sort compare imports; + cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; + } in + clear_env_hcons (); + output_cmt oc cmt; + close_out oc; + set_saved_types []; + end; + set_saved_types [] diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli new file mode 100644 index 0000000000..578d1743f3 --- /dev/null +++ b/typing/cmt_format.mli @@ -0,0 +1,112 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(** cmt and cmti files format. *) + +(** The layout of a cmt file is as follows: + <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\} + where <cmi> is the cmi file format: + <cmi> := <cmi magic> <cmi info>. + More precisely, the optional <cmi> part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern of pattern + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + +exception Error of error + +(** [read filename] opens filename, and extract both the cmi_infos, if + it exists, and the cmt_infos, if it exists. Thus, it can be used + with .cmi, .cmt and .cmti files. + + .cmti files always contain a cmi_infos at the beginning. .cmt files + only contain a cmi_infos at the beginning if there is no associated + .cmti file. +*) +val read : string -> Cmi_format.cmi_infos option * cmt_infos option + +val read_cmt : string -> cmt_infos +val read_cmi : string -> Cmi_format.cmi_infos + +(** [save_cmt modname filename binary_annots sourcefile initial_env sg] + writes a cmt(i) file. *) +val save_cmt : + string -> (* filename.cmt to generate *) + string -> (* module name *) + binary_annots -> + string option -> (* source file *) + Env.t -> (* initial env *) + Types.signature option -> (* if a .cmi was generated, + the signature saved there *) + unit + +(* Miscellaneous functions *) + +val read_magic_number : in_channel -> string + +val add_saved_type : binary_part -> unit +val get_saved_types : unit -> binary_part list +val set_saved_types : binary_part list -> unit + + +(* + + val is_magic_number : string -> bool + val read : in_channel -> Env.cmi_infos option * t + val write_magic_number : out_channel -> unit + val write : out_channel -> t -> unit + + val find : string list -> string -> string + val read_signature : 'a -> string -> Types.signature * 'b list * 'c list + +*) diff --git a/typing/ctype.ml b/typing/ctype.ml index d9945d2853..0d6a1039af 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -189,14 +189,14 @@ module TypePairs = (**** unification mode ****) -type 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 set_mode mode ?(generate = (mode = Pattern)) f = let old_unification_mode = !umode and old_gen = !generate_equations in try @@ -218,10 +218,10 @@ let in_current_module = function | Path.Pident _ -> true | Path.Pdot _ | Path.Papply _ -> false -let in_pervasives p = +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 @@ -240,8 +240,6 @@ let is_datatype decl= (**** Object field manipulation. ****) -let dummy_method = "*dummy method*" - let object_fields ty = match (repr ty).desc with Tobject (fields, _) -> fields @@ -368,18 +366,18 @@ let hide_private_methods ty = let rec signature_of_class_type = function - Tcty_constr (_, _, cty) -> signature_of_class_type cty - | Tcty_signature sign -> sign - | Tcty_fun (_, ty, cty) -> signature_of_class_type cty + Cty_constr (_, _, cty) -> signature_of_class_type cty + | Cty_signature sign -> sign + | Cty_fun (_, ty, cty) -> signature_of_class_type cty let self_type cty = repr (signature_of_class_type cty).cty_self let rec class_type_arity = function - Tcty_constr (_, _, cty) -> class_type_arity cty - | Tcty_signature _ -> 0 - | Tcty_fun (_, _, cty) -> 1 + class_type_arity cty + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_fun (_, _, cty) -> 1 + class_type_arity cty (*******************************************) @@ -521,13 +519,13 @@ let closed_type_decl decl = Type_abstract -> () | Type_variant v -> - List.iter + List.iter (fun (_, tyl,ret_type_opt) -> match ret_type_opt with | Some _ -> () | None -> List.iter closed_type tyl) - v + v | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; @@ -633,12 +631,14 @@ let rec generalize_structure var_level ty = if ty.level <> generic_level then begin 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 @@ -653,9 +653,21 @@ 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 *) @@ -673,13 +685,13 @@ 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 = +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 - | _ -> + with + | Not_found -> (* no newtypes in predef *) Path.binding_time p @@ -720,7 +732,8 @@ let rec update_level env level ty = end; set_level ty level; iter_type_expr (update_level env level) ty - | Tfield(lab, _, _, _) when lab = dummy_method -> + | Tfield(lab, _, ty1, _) + when lab = dummy_method && (repr ty1).level > level-> raise (Unify [(ty, newvar2 level)]) | _ -> set_level ty level; @@ -906,8 +919,8 @@ let abbreviations = ref (ref Mnil) (* 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 rec copy ?env ?partial ?keep_names ty = + let copy = copy ?env ?partial ?keep_names in let ty = repr ty in match ty.desc with Tsubst ty -> ty @@ -996,7 +1009,9 @@ let rec copy ?env ?partial ty = dup_kind r; copy_type_desc copy desc end - | _ -> copy_type_desc copy desc + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc end; t @@ -1021,7 +1036,7 @@ let instance ?partial env sch = let instance_def sch = let ty = copy sch in cleanup_types (); - ty + ty let instance_list env schl = let env = gadt_env env in @@ -1030,9 +1045,9 @@ let instance_list env schl = tyl let reified_var_counter = ref Vars.empty - -(* names given to new type constructors. - Used for existential types and + +(* names given to new type constructors. + Used for existential types and local constraints *) let get_new_abstract_name s = let index = @@ -1041,7 +1056,7 @@ let get_new_abstract_name s = reified_var_counter := Vars.add s index !reified_var_counter; Printf.sprintf "%s#%d" s index -let new_declaration newtype manifest = +let new_declaration newtype manifest = { type_params = []; type_arity = 0; @@ -1059,7 +1074,7 @@ let instance_constructor ?in_pattern cstr = begin match in_pattern with | None -> () | Some (env, newtype_lev) -> - let process existential = + let process existential = let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in let name = match repr existential with @@ -1069,16 +1084,16 @@ let instance_constructor ?in_pattern cstr = 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 + 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) -let instance_parameterized_type sch_args sch = - let ty_args = List.map copy sch_args in +let instance_parameterized_type ?keep_names sch_args sch = + let ty_args = List.map (copy ?keep_names) sch_args in let ty = copy sch in cleanup_types (); (ty_args, ty) @@ -1109,18 +1124,18 @@ let instance_declaration decl = let instance_class params cty = let rec copy_class_type = function - Tcty_constr (path, tyl, cty) -> - Tcty_constr (path, List.map copy tyl, copy_class_type cty) - | Tcty_signature sign -> - Tcty_signature + Cty_constr (path, tyl, cty) -> + Cty_constr (path, List.map copy tyl, copy_class_type cty) + | Cty_signature sign -> + Cty_signature {cty_self = copy sign.cty_self; 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} - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, copy ty, copy_class_type cty) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, copy ty, copy_class_type cty) in let params' = List.map copy params in let cty' = copy_class_type cty in @@ -1347,7 +1362,7 @@ let expand_abbrev_gen kind find_type_expansion env ty = | _ -> assert false -(* inside objects and variants we do not want to +(* 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 @@ -1434,10 +1449,13 @@ let expand_head_opt env ty = let enforce_constraints env ty = match ty with {desc = Tconstr (path, args, abbrev); level = level} -> - let decl = Env.find_type path env in - ignore - (subst env level Public (ref Mnil) None decl.type_params args - (newvar2 level)) + begin try + let decl = Env.find_type path env in + ignore + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) + with Not_found -> () + end | _ -> assert false @@ -1487,7 +1505,7 @@ let rec non_recursive_abbrev env ty0 ty = with Cannot_expand -> if !Clflags.recursive_types && (in_current_module p || in_pervasives p || - is_datatype (Env.find_type p env)) + try is_datatype (Env.find_type p env) with Not_found -> false) then () else iter_type_expr (non_recursive_abbrev env ty0) ty end @@ -1790,26 +1808,26 @@ let deep_occur t0 ty = let newtype_level = ref None -let get_newtype_level () = +let get_newtype_level () = match !newtype_level with | None -> assert false | Some x -> x -(* a local constraint can be added only if the rhs +(* 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 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 + 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 rec iterator ty = let ty = repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; @@ -1829,16 +1847,18 @@ let reify env t = 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 +let is_abstract_newtype env p = + try + let decl = Env.find_type p env in + not (decl.type_newtype_level = None) && + decl.type_manifest = None && + decl.type_kind = Type_abstract + with Not_found -> false -(* mcomp type_pairs subst env t1 t2 does not raise an +(* 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. + 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 *) @@ -1849,7 +1869,7 @@ let rec mcomp type_pairs subst env t1 t2 = let t2 = repr t2 in if t1 == t2 then () else match (t1.desc, t2.desc) with - | (Tvar _, _) + | (Tvar _, _) | (_, Tvar _) -> fatal_error "types should not include variables" | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> @@ -1949,40 +1969,42 @@ and mcomp_row type_pairs subst env row1 row2 = | _ -> ()) pairs -and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = +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 []) + try + let decl = Env.find_type p1 env in + let decl' = Env.find_type p2 env in + if Path.same p1 p2 then + (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2) + 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 []) + with Not_found -> () -and mcomp_type_option type_pairs subst env t t' = +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 []) + | Some t, Some t' -> mcomp type_pairs subst env t t' + | _ -> raise (Unify []) -and mcomp_variant_description type_pairs subst env = +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' + if name = name' && mflag = mflag' then iter xs ys else raise (Unify []) | [],[] -> () @@ -1990,12 +2012,12 @@ and mcomp_variant_description type_pairs subst env = in iter -and mcomp_record_description type_pairs subst env = +and mcomp_record_description type_pairs subst env = let rec iter = fun x y -> - match x, y with + 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' + if name = name' && mutable_flag = mutable_flag' then iter xs ys else raise (Unify []) | [], [] -> () @@ -2019,27 +2041,28 @@ let find_lowest_level 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 +let find_newtype_level env path = + try match (Env.find_type path env).type_newtype_level with Some x -> x | None -> assert false - + with Not_found -> assert false + let add_gadt_equation env source destination = - let destination = duplicate_type destination in + 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 () + 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 = +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 @@ -2055,7 +2078,7 @@ let rec unify (env:Env.t ref) t1 t2 = 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; begin match (t1.desc, t2.desc) with @@ -2064,12 +2087,12 @@ let rec unify (env:Env.t ref) t1 t2 = | (Tconstr _, Tvar _) when deep_occur t2 t1 -> unify2 env t1 t2 | (Tvar _, _) -> - occur !env t1 t2; + occur !env t1 t2; occur_univar !env t2; link_type t1 t2; update_level !env t1.level t2 | (_, Tvar _) -> - occur !env t2 t1; + occur !env t2 t1; occur_univar !env t1; link_type t2 t1; update_level !env t2.level t1 @@ -2155,14 +2178,15 @@ and unify3 env t1 t1' t2 t2' = | (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 + begin match !umode with + | Expression -> + occur !env t1' t2'; + link_type t1' t2 + | Pattern -> + add_type_equality t1' t2' + end; + try + begin 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; @@ -2176,7 +2200,7 @@ and unify3 env t1 t1' t2 t2' = | (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) + || try is_datatype (Env.find_type p1 !env) with Not_found -> false then unify_list env tl1 tl2 else @@ -2236,20 +2260,20 @@ and unify3 env t1 t1' t2 t2' = 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; + (* XXX Commentaires + changer "create_recursion" *) + if create_recursion then + 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 *) + with Unify trace -> + t1'.desc <- d1; + raise (Unify trace) end and unify_list env tl1 tl2 = @@ -2290,9 +2314,9 @@ and unify_fields env ty1 ty2 = (* Optimization *) List.iter (fun (n, k1, t1, k2, t2) -> unify_kind k1 k2; - try + try if !trace_gadt_instances then update_level !env va.level t1; - unify env t1 t2 + unify env t1 t2 with Unify trace -> raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)), newty (Tfield(n, k2, t2, newty Tnil)))::trace))) @@ -2329,11 +2353,12 @@ and unify_row env row1 row2 = with Not_found -> ()) r2 end; + let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 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 newty2 (min rm1.level rm2.level) (Tvar None) in - let fixed = row1.row_fixed || row2.row_fixed + let fixed = fixed1 || fixed2 and closed = row1.row_closed || row2.row_closed in let keep switch = List.for_all @@ -2367,8 +2392,8 @@ and unify_row env row1 row2 = 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 row) + || closed && row_fixed row && 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; @@ -2377,7 +2402,7 @@ and unify_row env row1 row2 = 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 row_fixed row then if more == rm then () else if is_Tvar rm then link_type rm more else unify env rm more else @@ -2391,7 +2416,7 @@ and unify_row env row1 row2 = set_more row1 r2; List.iter (fun (l,f1,f2) -> - try unify_row_field env row1.row_fixed row2.row_fixed more l f1 f2 + try unify_row_field env fixed1 fixed2 more l f1 f2 with Unify trace -> raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) @@ -2409,7 +2434,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = - (m1 || m2 || + (m1 || m2 || fixed1 || fixed2 || !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> @@ -2430,8 +2455,8 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = 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 + | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 + | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1 | Rabsent, Rabsent -> () | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> set_row_field e1 f2; @@ -2485,7 +2510,7 @@ let unify_var env t1 t2 = if reset_tracing then trace_gadt_instances := false; with Unify trace -> if reset_tracing then trace_gadt_instances := false; - let expanded_trace = expand_trace env ((t1,t2)::trace) in + let expanded_trace = expand_trace env ((t1,t2)::trace) in raise (Unify expanded_trace) end | _ -> @@ -2855,7 +2880,7 @@ let rec rigidify_rec vars ty = | Tvariant row -> let row = row_repr row in let more = repr row.row_more in - if is_Tvar more && not row.row_fixed then begin + if is_Tvar more && not (row_fixed row) 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')) @@ -3100,16 +3125,16 @@ exception Failure of class_match_failure list let rec moregen_clty trace type_pairs env cty1 cty2 = try match cty1, cty2 with - Tcty_constr (_, _, cty1), _ -> + Cty_constr (_, _, cty1), _ -> moregen_clty true type_pairs env cty1 cty2 - | _, Tcty_constr (_, _, cty2) -> + | _, Cty_constr (_, _, cty2) -> moregen_clty true type_pairs env cty1 cty2 - | Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 -> + | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try moregen true type_pairs env ty1 ty2 with Unify trace -> raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) end; moregen_clty false type_pairs env cty1' cty2' - | Tcty_signature sign1, Tcty_signature sign2 -> + | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.cty_self) in let ty2 = object_fields (repr sign2.cty_self) in let (fields1, rest1) = flatten_fields ty1 @@ -3233,18 +3258,18 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = let rec equal_clty trace type_pairs subst env cty1 cty2 = try match cty1, cty2 with - Tcty_constr (_, _, cty1), Tcty_constr (_, _, cty2) -> + Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> equal_clty true type_pairs subst env cty1 cty2 - | Tcty_constr (_, _, cty1), _ -> + | Cty_constr (_, _, cty1), _ -> equal_clty true type_pairs subst env cty1 cty2 - | _, Tcty_constr (_, _, cty2) -> + | _, Cty_constr (_, _, cty2) -> equal_clty true type_pairs subst env cty1 cty2 - | Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 -> + | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) end; equal_clty false type_pairs subst env cty1' cty2' - | Tcty_signature sign1, Tcty_signature sign2 -> + | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.cty_self) in let ty2 = object_fields (repr sign2.cty_self) in let (fields1, rest1) = flatten_fields ty1 @@ -3359,14 +3384,16 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = raise (Failure [CM_Type_parameter_mismatch (expand_trace env trace)])) patt_params subj_params; - (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) + (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) equal_clty false type_pairs subst env - (Tcty_signature sign1) (Tcty_signature sign2); + (Cty_signature sign1) (Cty_signature sign2); (* Use moregeneral for class parameters, need to recheck everything to keeps relationships (PR#4824) *) - let clty_params = List.fold_right (fun ty cty -> Tcty_fun ("*",ty,cty)) in + let clty_params = + List.fold_right (fun ty cty -> Cty_fun ("*",ty,cty)) in match_class_types ~trace:false env - (clty_params patt_params patt_type) (clty_params subj_params subj_type) + (clty_params patt_params patt_type) + (clty_params subj_params subj_type) with Failure r -> r end @@ -4029,11 +4056,11 @@ let nondep_type_decl env mid id is_covariant decl = | Type_variant cstrs -> Type_variant (List.map - (fun (c, tl,ret_type_opt) -> - let ret_type_opt = + (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)) + (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) cstrs) | Type_record(lbls, rep) -> Type_record @@ -4082,15 +4109,15 @@ let nondep_class_signature env id sign = let rec nondep_class_type env id = function - Tcty_constr (p, _, cty) when Path.isfree id p -> + Cty_constr (p, _, cty) when Path.isfree id p -> nondep_class_type env id cty - | Tcty_constr (p, tyl, cty) -> - Tcty_constr (p, List.map (nondep_type_rec env id) tyl, + | Cty_constr (p, tyl, cty) -> + Cty_constr (p, List.map (nondep_type_rec env id) tyl, nondep_class_type env id cty) - | Tcty_signature sign -> - Tcty_signature (nondep_class_signature env id sign) - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty) + | Cty_signature sign -> + Cty_signature (nondep_class_signature env id sign) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty) let nondep_class_declaration env id decl = assert (not (Path.isfree id decl.cty_path)); diff --git a/typing/ctype.mli b/typing/ctype.mli index f835dfc70f..790cd5367e 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -55,7 +55,6 @@ val none: type_expr val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) -val dummy_method: label val object_fields: type_expr -> type_expr val flatten_fields: type_expr -> (string * field_kind * type_expr) list * type_expr @@ -122,6 +121,7 @@ val instance_constructor: constructor_description -> type_expr list * type_expr (* Same, for a constructor *) val instance_parameterized_type: + ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr val instance_parameterized_type_2: type_expr list -> type_expr list -> type_expr -> @@ -155,7 +155,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. *) + (* 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. *) @@ -181,7 +182,7 @@ val rigidify: type_expr -> type_expr list (* "Rigidify" a type and return its type variable *) val all_distinct_vars: Env.t -> type_expr list -> bool (* Check those types are all distinct type variables *) -val matches : Env.t -> type_expr -> type_expr -> bool +val matches: Env.t -> type_expr -> type_expr -> bool (* Same as [moregeneral false], implemented using the two above functions and backtracking. Ignore levels *) @@ -203,7 +204,7 @@ type class_match_failure = | CM_Private_method of string | CM_Virtual_method of string val match_class_types: - ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list + ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list (* Check if the first class type is more general than the second. *) val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool (* [equal env [x1...xn] tau [y1...yn] sigma] @@ -234,7 +235,7 @@ val nondep_class_declaration: Env.t -> Ident.t -> class_declaration -> class_declaration (* Same for class declarations. *) val nondep_cltype_declaration: - Env.t -> Ident.t -> cltype_declaration -> cltype_declaration + Env.t -> Ident.t -> class_type_declaration -> class_type_declaration (* Same for class type declarations. *) val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool diff --git a/typing/datarepr.ml b/typing/datarepr.ml index bc05d2a845..ebd4e17da2 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -111,7 +111,7 @@ let label_descrs ty_res lbls repres priv = [] -> [] | (name, mut_flag, ty_arg) :: rest -> let lbl = - { lbl_name = name; + { lbl_name = Ident.name name; lbl_res = ty_res; lbl_arg = ty_arg; lbl_mut = mut_flag; diff --git a/typing/datarepr.mli b/typing/datarepr.mli index bc1190d454..527fecb573 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -19,17 +19,17 @@ open Asttypes open Types val constructor_descrs: - type_expr -> (string * type_expr list * type_expr option) list -> - private_flag -> (string * constructor_description) list + type_expr -> (Ident.t * type_expr list * type_expr option) list -> + private_flag -> (Ident.t * constructor_description) list val exception_descr: Path.t -> exception_declaration -> constructor_description val label_descrs: - type_expr -> (string * mutable_flag * type_expr) list -> + type_expr -> (Ident.t * mutable_flag * type_expr) list -> record_representation -> private_flag -> - (string * label_description) list + (Ident.t * label_description) list exception Constr_not_found val find_constr_by_tag: - constructor_tag -> (string * type_expr list * type_expr option) list -> - string * type_expr list * type_expr option + constructor_tag -> (Ident.t * type_expr list * type_expr option) list -> + Ident.t * type_expr list * type_expr option diff --git a/typing/env.ml b/typing/env.ml index 8d1e43079d..8a4fc81d89 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -14,6 +14,7 @@ (* Environment handling *) +open Cmi_format open Config open Misc open Asttypes @@ -24,26 +25,76 @@ open Btype let add_delayed_check_forward = ref (fun _ -> assert false) -let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Hashtbl.create 16 +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). *) + 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 -let used_constructors : (string * Location.t * string, (unit -> unit)) Hashtbl.t = 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 | Need_recursive_types of string * string exception Error of error +module EnvLazy : sig + type ('a,'b) t + + val force : ('a -> 'b) -> ('a,'b) t -> 'b + val create : 'a -> ('a,'b) t + +end = struct + + type ('a,'b) t = ('a,'b) eval ref + + and ('a,'b) eval = + Done of 'b + | Raise of exn + | Thunk of 'a + + let force f x = + match !x with + Done x -> x + | Raise e -> raise e + | Thunk e -> + try + let y = f e in + x := Done y; + y + with e -> + x := Raise e; + raise e + + let create x = + let x = ref (Thunk x) in + x + +end + + type summary = Env_empty | Env_value of summary * Ident.t * value_description @@ -52,32 +103,32 @@ type summary = | Env_module of summary * Ident.t * module_type | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration - | Env_cltype of summary * Ident.t * cltype_declaration + | Env_cltype of summary * Ident.t * class_type_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 + type 'a t = ('a * bool ref) Ident.tbl - let empty = (Ident.empty, Ident.empty) + let 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 add id x tbl = + Ident.add id (x, !current_slot) tbl - let find_same_not_using id (tbl, _) = - Ident.find_same id tbl + let find_same_not_using id tbl = + fst (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_same id tbl = + let (x, slot) = Ident.find_same id tbl in + slot := true; + x - let find_name s (tbl, slots) = - (try Ident.find_name s slots := true with Not_found -> ()); - Ident.find_name s tbl + let find_name s tbl = + let (x, slot) = Ident.find_name s tbl in + slot := true; + x let with_slot slot f x = let old_slot = !current_slot in @@ -86,33 +137,35 @@ module EnvTbl = (fun () -> f x) (fun () -> current_slot := old_slot) - let keys (tbl, _) = + let keys tbl = Ident.keys tbl - let map f (tbl,slots) = Ident.map f tbl,slots + let map f tbl = Ident.map f tbl end type t = { 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: (Path.t * constructor_description) EnvTbl.t; + labels: (Path.t * label_description) EnvTbl.t; constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t; types: (Path.t * type_declaration) EnvTbl.t; 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; + cltypes: (Path.t * class_type_declaration) EnvTbl.t; (*> JOCAML *) continuations : (Path.t * continuation_description) EnvTbl.t; (*< JOCAML *) summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; + in_signature: bool; } -and module_components = module_components_repr Lazy.t +and module_components = + (t * Subst.t * Path.t * Types.module_type, module_components_repr) EnvLazy.t and module_components_repr = Structure_comps of structure_components @@ -123,14 +176,15 @@ 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: + 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_modules: + (string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t; mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t; mutable comp_components: (string, (module_components * int)) Tbl.t; mutable comp_classes: (string, (class_declaration * int)) Tbl.t; - mutable comp_cltypes: (string, (cltype_declaration * int)) Tbl.t + mutable comp_cltypes: (string, (class_type_declaration * int)) Tbl.t } and functor_components = { @@ -142,24 +196,31 @@ and functor_components = { fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *) } +let subst_modtype_maker (subst, mty) = Subst.modtype subst mty + let empty = { values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty; - labels = EnvTbl.empty; types = 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; (*> JOCAML *) continuations = EnvTbl.empty; (*<JOCAML *) - summary = Env_empty; local_constraints = false; gadt_instances = [] } + } + +let in_signature env = {env with in_signature = true} let diff_keys is_local tbl1 tbl2 = let keys2 = EnvTbl.keys tbl2 in List.filter (fun id -> is_local (EnvTbl.find_same_not_using id tbl2) && - try ignore (EnvTbl.find_same_not_using id tbl1); false with Not_found -> true) + try ignore (EnvTbl.find_same_not_using id tbl1); false + with Not_found -> true) keys2 let is_ident = function @@ -168,13 +229,9 @@ let is_ident = function let is_local (p, _) = is_ident p -let is_local_exn = function - {cstr_tag = Cstr_exception (p, _)} -> is_ident p - | _ -> false - let diff env1 env2 = diff_keys is_local env1.values env2.values @ - diff_keys is_local_exn env1.constrs env2.constrs @ + diff_keys is_local env1.constrs env2.constrs @ diff_keys is_local env1.modules env2.modules @ diff_keys is_local env1.classes env2.classes @@ -183,6 +240,9 @@ let diff env1 env2 = let components_of_module' = ref ((fun env sub path mty -> assert false) : t -> Subst.t -> Path.t -> module_type -> module_components) +let components_of_module_maker' = + ref ((fun (env, sub, path, mty) -> assert false) : + t * Subst.t * Path.t * module_type -> module_components_repr) let components_of_functor_appl' = ref ((fun f p1 p2 -> assert false) : functor_components -> Path.t -> Path.t -> module_components) @@ -198,8 +258,6 @@ let current_unit = ref "" (* Persistent structure descriptions *) -type pers_flags = Rectypes - type pers_struct = { ps_name: string; ps_sig: signature; @@ -209,7 +267,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 *) @@ -226,28 +284,15 @@ let check_consistency filename crcs = (* Reading persistent structures from .cmi files *) let read_pers_struct modname filename = - let ic = open_in_bin filename in - try - let buffer = Misc.input_bytes ic (String.length cmi_magic_number) in - if buffer <> cmi_magic_number then begin - close_in ic; - 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 - let flags = input_value ic in - close_in ic; - let comps = + let cmi = read_cmi filename in + let name = cmi.cmi_name in + let sign = cmi.cmi_sign in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let comps = !components_of_module' empty Subst.identity (Pident(Ident.create_persistent name)) - (Tmty_signature sign) in + (Mty_signature sign) in let ps = { ps_name = name; ps_sig = sign; ps_comps = comps; @@ -262,17 +307,26 @@ 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 := ""; @@ -281,6 +335,12 @@ let reset_cache () = 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 @@ -298,7 +358,9 @@ let rec find_module_descr path env = else raise Not_found end | Pdot(p, s, pos) -> - begin match Lazy.force(find_module_descr p env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in descr @@ -306,7 +368,9 @@ let rec find_module_descr path env = raise Not_found end | Papply(p1, p2) -> - begin match Lazy.force(find_module_descr p1 env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p1 env) + with Functor_comps f -> !components_of_functor_appl' f p1 p2 | Structure_comps c -> @@ -319,7 +383,9 @@ let find proj1 proj2 path 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 + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in data | Functor_comps f -> @@ -330,6 +396,8 @@ let find proj1 proj2 path env = let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) +and find_annot = + find (fun env -> env.annotations) (fun sc -> sc.comp_annotations) and find_type = find (fun env -> env.types) (fun sc -> sc.comp_types) and find_constructors = @@ -371,8 +439,8 @@ let find_type_expansion_opt path env = let find_modtype_expansion path env = match find_modtype path env with - Tmodtype_abstract -> raise Not_found - | Tmodtype_manifest mty -> mty + Modtype_abstract -> raise Not_found + | Modtype_manifest mty -> mty let find_module path env = match path with @@ -383,13 +451,16 @@ let find_module path env = with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in - Tmty_signature(ps.ps_sig) + Mty_signature(ps.ps_sig) else raise Not_found end | Pdot(p, s, pos) -> - begin match Lazy.force (find_module_descr p env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with Structure_comps c -> - let (data, pos) = Tbl.find s c.comp_modules in Lazy.force data + let (data, pos) = Tbl.find s c.comp_modules in + EnvLazy.force subst_modtype_maker data | Functor_comps f -> raise Not_found end @@ -410,7 +481,7 @@ let rec lookup_module_descr lid env = end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in - begin match Lazy.force descr with + begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in (Pdot(p, s, pos), descr) @@ -420,7 +491,7 @@ let rec lookup_module_descr lid env = | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in let (p2, mty2) = lookup_module l2 env in - begin match Lazy.force desc1 with + begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; (Papply(p1, p2), !components_of_functor_appl' f p1 p2) @@ -436,14 +507,14 @@ and lookup_module lid env = with Not_found -> if s = !current_unit then raise Not_found; let ps = find_pers_struct s in - (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig) + (Pident(Ident.create_persistent s), Mty_signature ps.ps_sig) end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in - begin match Lazy.force descr with + begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in - (Pdot(p, s, pos), Lazy.force data) + (Pdot(p, s, pos), EnvLazy.force subst_modtype_maker data) | Functor_comps f -> raise Not_found end @@ -451,7 +522,7 @@ and lookup_module lid env = let (p1, desc1) = lookup_module_descr l1 env in let (p2, mty2) = lookup_module l2 env in let p = Papply(p1, p2) in - begin match Lazy.force desc1 with + begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) @@ -466,7 +537,7 @@ let lookup proj1 proj2 lid 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 + begin match EnvLazy.force !components_of_module_maker' desc with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in (Pdot(p, s, pos), data) @@ -482,7 +553,7 @@ let lookup_simple proj1 proj2 lid 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 + begin match EnvLazy.force !components_of_module_maker' desc with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in data @@ -499,9 +570,9 @@ let lookup_value = let lookup_annot id e = lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e and lookup_constructor = - lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) + lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs) and lookup_label = - lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) + lookup (fun env -> env.labels) (fun sc -> sc.comp_labels) and lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) and lookup_modtype = @@ -524,12 +595,12 @@ let mark_type_used name vd = try Hashtbl.find type_declarations (name, vd.type_loc) () with Not_found -> () -let mark_constructor_used name vd constr = - try Hashtbl.find used_constructors (name, vd.type_loc, constr) () +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 ed constr = - try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) () +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 = @@ -545,7 +616,9 @@ let set_value_used_callback name vd callback = 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 + 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 = @@ -558,6 +631,13 @@ let lookup_type lid env = mark_type_used (Longident.last lid) desc; r +(* [path] must be the path to a type, not to a module ! *) +let rec path_subst_last path id = + match path with + Pident _ -> Pident id + | Pdot (p, name, pos) -> Pdot(p, Ident.name id, pos) + | Papply (p1, p2) -> assert false + let mark_type_path env path = let decl = try find_type path env with Not_found -> assert false in mark_type_used (Path.last path) decl @@ -567,27 +647,27 @@ let ty_path = function | _ -> assert false let lookup_constructor lid env = - let desc = lookup_constructor lid env in + let (_,desc) as c = lookup_constructor lid env in mark_type_path env (ty_path desc.cstr_res); - desc + c -let mark_constructor env name 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) () + 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 ty_name ty_decl name + mark_constructor_used usage ty_name ty_decl name let lookup_label lid env = - let desc = lookup_label lid env in + let (_,desc) as c = lookup_label lid env in mark_type_path env (ty_path desc.lbl_res); - desc + c let lookup_class lid env = let (_, desc) as r = lookup_class lid env in @@ -652,7 +732,7 @@ let add_gadt_instance_chain env lv t = let rec scrape_modtype mty env = match mty with - Tmty_ident path -> + Mty_ident path -> begin try scrape_modtype (find_modtype_expansion path env) env with Not_found -> @@ -663,7 +743,7 @@ let rec scrape_modtype mty env = (* Compute constructor descriptions *) let constructors_of_type ty_path decl = - let handle_variants cstrs = + let handle_variants cstrs = Datarepr.constructor_descrs (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) cstrs decl.type_private @@ -687,36 +767,36 @@ let labels_of_type ty_path decl = let rec prefix_idents root pos sub = function [] -> ([], sub) - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in let (pl, final_sub) = prefix_idents root nextpos sub rem in (p::pl, final_sub) - | Tsig_type(id, decl, _) :: rem -> + | Sig_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) - | Tsig_exception(id, decl) :: rem -> + | Sig_exception(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) sub rem in (p::pl, final_sub) - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) (Subst.add_module id p sub) rem in (p::pl, final_sub) - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos - (Subst.add_modtype id (Tmty_ident p) sub) rem in + (Subst.add_modtype id (Mty_ident p) sub) rem in (p::pl, final_sub) - | Tsig_class(id, decl, _) :: rem -> + | Sig_class(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in (p::pl, final_sub) - | Tsig_cltype(id, decl, _) :: rem -> + | Sig_class_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos sub rem in (p::pl, final_sub) @@ -724,11 +804,14 @@ let rec prefix_idents root pos sub = function (* Compute structure descriptions *) let rec components_of_module env sub path mty = - lazy(match scrape_modtype mty env with - Tmty_signature sg -> + EnvLazy.create (env, sub, path, mty) + +and components_of_module_maker (env, sub, path, mty) = + (match scrape_modtype mty env with + Mty_signature sg -> let c = { comp_values = Tbl.empty; comp_annotations = Tbl.empty; - comp_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; @@ -739,7 +822,7 @@ let rec components_of_module env sub path mty = let pos = ref 0 in List.iter2 (fun item path -> match item with - Tsig_value(id, decl) -> + Sig_value(id, decl) -> let decl' = Subst.value_description sub decl in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; @@ -751,32 +834,34 @@ let rec components_of_module env sub path mty = begin match decl.val_kind with Val_prim _ -> () | _ -> incr pos end - | Tsig_type(id, decl, _) -> + | Sig_type(id, decl, _) -> 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) + 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) + c.comp_constrs <- + Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs) 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) + c.comp_labels <- + Tbl.add (Ident.name name) (descr, nopos) c.comp_labels) (labels); env := store_type_infos id path decl !env - | Tsig_exception(id, decl) -> + | Sig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in let cstr = Datarepr.exception_descr path decl' in c.comp_constrs <- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs; incr pos - | Tsig_module(id, mty, _) -> - let mty' = lazy (Subst.modtype sub mty) in + | Sig_module(id, mty, _) -> + let mty' = EnvLazy.create (sub, mty) in c.comp_modules <- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules; let comps = components_of_module !env sub path mty in @@ -784,23 +869,23 @@ let rec components_of_module env sub path mty = Tbl.add (Ident.name id) (comps, !pos) c.comp_components; env := store_module id path mty !env; incr pos - | Tsig_modtype(id, decl) -> + | Sig_modtype(id, decl) -> let decl' = Subst.modtype_declaration sub decl in c.comp_modtypes <- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; env := store_modtype id path decl !env - | Tsig_class(id, decl, _) -> + | Sig_class(id, decl, _) -> let decl' = Subst.class_declaration sub decl in c.comp_classes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_classes; incr pos - | Tsig_cltype(id, decl, _) -> + | Sig_class_type(id, decl, _) -> let decl' = Subst.cltype_declaration sub decl in c.comp_cltypes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) sg pl; Structure_comps c - | Tmty_functor(param, ty_arg, ty_res) -> + | Mty_functor(param, ty_arg, ty_res) -> Functor_comps { fcomp_param = param; (* fcomp_arg must be prefixed eagerly, because it is interpreted @@ -811,11 +896,11 @@ let rec components_of_module env sub path mty = fcomp_env = env; fcomp_subst = sub; fcomp_cache = Hashtbl.create 17 } - | Tmty_ident p -> + | Mty_ident p -> Structure_comps { comp_values = Tbl.empty; comp_annotations = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = 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; @@ -837,7 +922,7 @@ and check_usage loc id warn tbl = 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; + may (fun f -> check_usage decl.val_loc id f value_declarations) check; { env with values = EnvTbl.add id (path, decl) env.values; summary = Env_value(env.summary, id, decl) } @@ -850,41 +935,47 @@ and store_annot id path annot 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; + 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 loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor "") then begin + 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, _) -> + begin fun (c, _) -> + let c = Ident.name c in let k = (ty, loc, c) in if not (Hashtbl.mem used_constructors k) then - let used = ref false in - Hashtbl.add used_constructors k (fun () -> used := true); - !add_delayed_check_forward - (fun () -> - if not !used then - Location.prerr_warning loc (Warnings.Unused_constructor c) - ) - ) + 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))) + end constructors end; { env with constrs = List.fold_right (fun (name, descr) constrs -> - EnvTbl.add (Ident.create name) descr constrs) - constructors + EnvTbl.add name (path_subst_last path name, descr) constrs) + constructors env.constrs; - constrs_by_path = - EnvTbl.add id + constrs_by_path = + EnvTbl.add id (path,List.map snd constructors) env.constrs_by_path; labels = List.fold_right (fun (name, descr) labels -> - EnvTbl.add (Ident.create name) descr labels) + EnvTbl.add name (path_subst_last path name, descr) labels) labels env.labels; types = EnvTbl.add id (path, info) env.types; @@ -902,22 +993,28 @@ and store_type_infos id path info env = and store_exception id path decl env = let loc = decl.exn_loc in - if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_exception "") then begin + 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 = ref false in - Hashtbl.add used_constructors k (fun () -> used := true); + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); !add_delayed_check_forward (fun () -> - if not !used then - Location.prerr_warning loc (Warnings.Unused_exception c) + if not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_exception + (c, used.cu_pattern) + ) ) end; end; { env with - constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs; + constrs = EnvTbl.add id (path_subst_last path id, + Datarepr.exception_descr path decl) env.constrs; summary = Env_exception(env.summary, id, decl) } and store_module id path mty env = @@ -968,7 +1065,8 @@ let components_of_functor_appl f p1 p2 = let _ = components_of_module' := components_of_module; - components_of_functor_appl' := components_of_functor_appl + components_of_functor_appl' := components_of_functor_appl; + components_of_module_maker' := components_of_module_maker (* Insertion of bindings by identifier *) @@ -1004,8 +1102,8 @@ and add_continuation id desc env = and remove_continuations t = {t with continuations = EnvTbl.empty} -let do_purge (path,d as c) = match d.val_kind with - | Val_channel _|Val_alone _ -> path,{ d with val_kind = Val_reg; } +let do_purge ((path,d),sl as c) = match d.val_kind with + | Val_channel _|Val_alone _ -> (path,{ d with val_kind = Val_reg; }),sl | _ -> c let remove_channel_info t = @@ -1038,13 +1136,13 @@ and enter_cltype = enter store_cltype let add_item comp env = match comp with - Tsig_value(id, decl) -> add_value id decl env - | Tsig_type(id, decl, _) -> add_type id decl env - | Tsig_exception(id, decl) -> add_exception id decl env - | Tsig_module(id, mty, _) -> add_module id mty env - | Tsig_modtype(id, decl) -> add_modtype id decl env - | Tsig_class(id, decl, _) -> add_class id decl env - | Tsig_cltype(id, decl, _) -> add_cltype id decl env + Sig_value(id, decl) -> add_value id decl env + | Sig_type(id, decl, _) -> add_type id decl env + | Sig_exception(id, decl) -> add_exception id decl env + | Sig_module(id, mty, _) -> add_module id mty env + | Sig_modtype(id, decl) -> add_modtype id decl env + | Sig_class(id, decl, _) -> add_class id decl env + | Sig_class_type(id, decl, _) -> add_cltype id decl env let rec add_signature sg env = match sg with @@ -1061,25 +1159,25 @@ let open_signature root sg env = List.fold_left2 (fun env item p -> match item with - Tsig_value(id, decl) -> + Sig_value(id, decl) -> let e1 = store_value (Ident.hide id) p (Subst.value_description sub decl) env in store_annot (Ident.hide id) p (Annot.Iref_external) e1 - | Tsig_type(id, decl, _) -> + | Sig_type(id, decl, _) -> store_type (Ident.hide id) p (Subst.type_declaration sub decl) env - | Tsig_exception(id, decl) -> + | Sig_exception(id, decl) -> store_exception (Ident.hide id) p (Subst.exception_declaration sub decl) env - | Tsig_module(id, mty, _) -> + | Sig_module(id, mty, _) -> store_module (Ident.hide id) p (Subst.modtype sub mty) env - | Tsig_modtype(id, decl) -> + | Sig_modtype(id, decl) -> store_modtype (Ident.hide id) p (Subst.modtype_declaration sub decl) env - | Tsig_class(id, decl, _) -> + | Sig_class(id, decl, _) -> store_class (Ident.hide id) p (Subst.class_declaration sub decl) env - | Tsig_cltype(id, decl, _) -> + | Sig_class_type(id, decl, _) -> store_cltype (Ident.hide id) p (Subst.cltype_declaration sub decl) env) env sg pl in @@ -1091,8 +1189,9 @@ 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 open_signature ?(loc = Location.none) ?(toplevel = false) root sg env = + if not toplevel && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") + then begin let used = ref false in !add_delayed_check_forward (fun () -> @@ -1100,8 +1199,8 @@ let open_signature ?(loc = Location.none) root sg env = 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 + end + else open_signature root sg env (* Read a signature from a file *) @@ -1130,29 +1229,29 @@ let save_signature_with_imports sg modname filename imports = let sg = Subst.signature (Subst.for_saving Subst.identity) sg in let oc = open_out_bin filename in try - output_string oc cmi_magic_number; - output_value oc (modname, sg); - flush oc; - let crc = Digest.file filename in - let crcs = (modname, crc) :: imports in - output_value oc crcs; - let flags = if !Clflags.recursive_types then [Rectypes] else [] in - output_value oc flags; + let cmi = { + cmi_name = modname; + cmi_sign = sg; + cmi_crcs = imports; + cmi_flags = if !Clflags.recursive_types then [Rectypes] else []; + } in + let crc = output_cmi filename oc cmi in close_out oc; (* Enter signature in persistent table so that imported_unit() will also return its crc *) let comps = components_of_module empty Subst.identity - (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in + (Pident(Ident.create_persistent modname)) (Mty_signature sg) in let ps = { ps_name = modname; ps_sig = sg; ps_comps = comps; - ps_crcs = crcs; + ps_crcs = (cmi.cmi_name, crc) :: imports; ps_filename = filename; - ps_flags = flags } in - Hashtbl.add persistent_structures modname ps; - Consistbl.set crc_units modname crc filename + ps_flags = cmi.cmi_flags } in + Hashtbl.add persistent_structures modname (Some ps); + Consistbl.set crc_units modname crc filename; + sg with exn -> close_out oc; remove_file filename; @@ -1161,6 +1260,78 @@ let save_signature_with_imports sg modname filename imports = let save_signature sg modname filename = save_signature_with_imports sg modname filename (imported_units()) +(* Folding on environments *) +let ident_tbl_fold f t acc = + List.fold_right + (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc) + (EnvTbl.keys t) + acc + +let find_all proj1 proj2 f lid env acc = + match lid with + | None -> + ident_tbl_fold + (fun id (p, data) acc -> f (Ident.name id) p data acc) + (proj1 env) acc + | Some l -> + let p, desc = lookup_module_descr l env in + begin match EnvLazy.force components_of_module_maker desc with + Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) + (proj2 c) acc + | Functor_comps _ -> + raise Not_found + end + +let fold_modules f lid env acc = + match lid with + | None -> + let acc = + ident_tbl_fold + (fun id (p, data) acc -> f (Ident.name id) p data acc) + env.modules + acc + in + Hashtbl.fold + (fun name ps acc -> + match ps with + None -> acc + | Some ps -> + f name (Pident(Ident.create_persistent name)) + (Mty_signature ps.ps_sig) acc) + persistent_structures + acc + | Some l -> + let p, desc = lookup_module_descr l env in + begin match EnvLazy.force components_of_module_maker desc with + Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> + f s (Pdot (p, s, pos)) + (EnvLazy.force subst_modtype_maker data) acc) + c.comp_modules + acc + | Functor_comps _ -> + raise Not_found + end + +let fold_values f = + find_all (fun env -> env.values) (fun sc -> sc.comp_values) f +and fold_constructors f = + find_all (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f +and fold_labels f = + find_all (fun env -> env.labels) (fun sc -> sc.comp_labels) f +and fold_types f = + find_all (fun env -> env.types) (fun sc -> sc.comp_types) f +and fold_modtypes f = + find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f +and fold_classs f = + find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f +and fold_cltypes f = + find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f + + (* Make the initial environment *) let initial = Predef.build_initial_env add_type add_exception empty @@ -1168,19 +1339,25 @@ let initial = Predef.build_initial_env add_type add_exception empty (* Return the environment summary *) let summary env = env.summary +let keep_only_summary env = + { empty with + summary = env.summary; + local_constraints = env.local_constraints; + in_signature = env.in_signature; +} + +let env_of_only_summary env_from_summary env = + let new_env = env_from_summary env.summary Subst.identity in + { new_env with + local_constraints = env.local_constraints; + in_signature = env.in_signature; + } (* Error report *) open Format let report_error ppf = function - | Not_an_interface filename -> fprintf ppf - "%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@ %a" Location.print_filename filename | Illegal_renaming(modname, filename) -> fprintf ppf "Wrong file naming: %a@ contains the compiled interface for@ %s" Location.print_filename filename modname diff --git a/typing/env.mli b/typing/env.mli index 14f1177482..9f551fd367 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -16,6 +16,17 @@ open Types +type summary = + Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_exception of summary * Ident.t * exception_declaration + | Env_module of summary * Ident.t * module_type + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_class of summary * Ident.t * class_declaration + | Env_cltype of summary * Ident.t * class_type_declaration + | Env_open of summary * Path.t + type t val empty: t @@ -25,12 +36,13 @@ val diff: t -> t -> Ident.t list (* Lookup by paths *) val find_value: Path.t -> t -> value_description +val find_annot: Path.t -> t -> Annot.ident val find_type: Path.t -> t -> type_declaration val find_constructors: Path.t -> t -> constructor_description list val find_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_cltype: Path.t -> t -> class_type_declaration val find_type_expansion: ?level:int -> Path.t -> t -> type_expr list * type_expr * int option @@ -50,27 +62,28 @@ val add_gadt_instance_chain: t -> int -> type_expr -> unit val lookup_value: Longident.t -> t -> Path.t * value_description val lookup_annot: Longident.t -> t -> Path.t * Annot.ident -val lookup_constructor: Longident.t -> t -> constructor_description -val lookup_label: Longident.t -> t -> label_description +val lookup_constructor: Longident.t -> t -> Path.t * constructor_description +val lookup_label: Longident.t -> t -> Path.t * label_description val lookup_type: Longident.t -> t -> Path.t * type_declaration val lookup_module: Longident.t -> t -> Path.t * module_type val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration val lookup_class: Longident.t -> t -> Path.t * class_declaration -val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration +val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration (*> JOCAML *) val lookup_continuation: Longident.t -> t -> Path.t * continuation_description (*< JOCAML *) (* Insertion by identifier *) -val add_value: ?check:(string -> Warnings.t) -> 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 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_cltype: Ident.t -> class_type_declaration -> t -> t val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t (* Insertion of all fields of a signature. *) @@ -88,21 +101,24 @@ val remove_channel_info: t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. *) -val open_signature: ?loc:Location.t -> Path.t -> signature -> t -> t +val open_signature: ?loc:Location.t -> ?toplevel:bool -> Path.t -> signature -> t -> t val open_pers_signature: string -> t -> t (* Insertion by name *) -val enter_value: ?check:(string -> Warnings.t) -> 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 val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t val enter_class: string -> class_declaration -> t -> Ident.t * t -val enter_cltype: string -> cltype_declaration -> t -> Ident.t * t +val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t (* Initialize the cache of in-core module interfaces. *) val reset_cache: unit -> unit +val reset_missing_cmis: unit -> unit (* Remember the name of the current compilation unit. *) val set_unit_name: string -> unit @@ -111,10 +127,10 @@ val set_unit_name: string -> unit val read_signature: string -> string -> signature (* Arguments: module name, file name. Results: signature. *) -val save_signature: signature -> string -> string -> unit +val save_signature: signature -> string -> string -> signature (* Arguments: signature, module name, file name. *) val save_signature_with_imports: - signature -> string -> string -> (string * Digest.t) list -> unit + signature -> string -> string -> (string * Digest.t) list -> signature (* Arguments: signature, module name, file name, imported units with their CRCs. *) @@ -133,25 +149,19 @@ val crc_units: Consistbl.t (* Summaries -- compact representation of an environment, to be exported in debugging information. *) -type summary = - Env_empty - | Env_value of summary * Ident.t * value_description - | Env_type of summary * Ident.t * type_declaration - | Env_exception of summary * Ident.t * exception_declaration - | Env_module of summary * Ident.t * module_type - | Env_modtype of summary * Ident.t * modtype_declaration - | Env_class of summary * Ident.t * class_declaration - | Env_cltype of summary * Ident.t * cltype_declaration - | Env_open of summary * Path.t - val summary: t -> summary +(* Return an equivalent environment where all fields have been reset, + except the summary. The initial environment can be rebuilt from the + summary, using Envaux.env_of_only_summary. *) + +val keep_only_summary : t -> t +val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t + + (* Error report *) 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 | Need_recursive_types of string * string @@ -162,17 +172,60 @@ open Format val report_error: formatter -> error -> unit + val mark_value_used: string -> value_description -> unit val mark_type_used: string -> type_declaration -> unit -val mark_constructor_used: string -> type_declaration -> string -> unit -val mark_constructor: t -> string -> constructor_description -> unit -val mark_exception_used: exception_declaration -> string -> unit -val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit -val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> 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 + +(** Folding over all identifiers (for analysis purpose) *) + +val fold_values: + (string -> Path.t -> Types.value_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_types: + (string -> Path.t -> Types.type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_constructors: + (string -> Path.t -> Types.constructor_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_labels: + (string -> Path.t -> Types.label_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +(** Persistent structures are only traversed if they are already loaded. *) +val fold_modules: + (string -> Path.t -> Types.module_type -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +val fold_modtypes: + (string -> Path.t -> Types.modtype_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_classs: + (string -> Path.t -> Types.class_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_cltypes: + (string -> Path.t -> Types.class_type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + + + diff --git a/typing/ident.mli b/typing/ident.mli index 6b0fc10888..715c70a0d8 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -14,7 +14,7 @@ (* Identifiers (unique names) *) -type t +type t = { stamp: int; name: string; mutable flags: int } val create: string -> t val create_persistent: string -> t diff --git a/typing/includeclass.mli b/typing/includeclass.mli index f5bc98a032..27784e9600 100644 --- a/typing/includeclass.mli +++ b/typing/includeclass.mli @@ -15,14 +15,13 @@ (* Inclusion checks for the class language *) open Types -open Typedtree open Ctype open Format val class_types: Env.t -> class_type -> class_type -> class_match_failure list val class_type_declarations: - Env.t -> cltype_declaration -> cltype_declaration -> + Env.t -> class_type_declaration -> class_type_declaration -> class_match_failure list val class_declarations: Env.t -> class_declaration -> class_declaration -> diff --git a/typing/includecore.ml b/typing/includecore.ml index 23c715f4df..e24c89ae79 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -118,11 +118,11 @@ type type_mismatch = | Constraint | Manifest | Variance - | Field_type of string - | Field_mutable of string - | Field_arity of string - | Field_names of int * string * string - | Field_missing of bool * string + | Field_type of Ident.t + | Field_mutable of Ident.t + | Field_arity of Ident.t + | Field_names of int * Ident.t * Ident.t + | Field_missing of bool * Ident.t | Record_representation of bool let nth n = @@ -141,17 +141,17 @@ let report_type_mismatch0 first second decl ppf err = | Manifest -> () | Variance -> pr "Their variances do not agree" | Field_type s -> - pr "The types for field %s are not equal" s + pr "The types for field %s are not equal" (Ident.name s) | Field_mutable s -> - pr "The mutability of field %s is different" s + pr "The mutability of field %s is different" (Ident.name s) | Field_arity s -> - pr "The arities for field %s differ" s + pr "The arities for field %s differ" (Ident.name s) | Field_names (n, name1, name2) -> pr "Their %s fields have different names, %s and %s" - (nth n) name1 name2 + (nth n) (Ident.name name1) (Ident.name name2) | Field_missing (b, s) -> pr "The field %s is only present in %s %s" - s (if b then second else first) decl + (Ident.name s) (if b then second else first) decl | Record_representation b -> pr "Their internal representations differ:@ %s %s %s" (if b then second else first) decl @@ -169,48 +169,58 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = | [], (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 - match ret1, ret2 with - | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> + if Ident.name cstr1 <> Ident.name cstr2 then + [Field_names (n, cstr1, cstr2)] + else if List.length arg1 <> List.length arg2 then + [Field_arity cstr1] + else match ret1, ret2 with + | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> [Field_type cstr1] | Some _, None | None, Some _ -> [Field_type cstr1] - | _ -> + | _ -> if Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env true (ty1::decl1.type_params) (ty2::decl2.type_params)) - (arg1) (arg2) - then + (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 [], [] -> [] | [], (lab2,_,_)::_ -> [Field_missing (true, lab2)] | (lab1,_,_)::_, [] -> [Field_missing (false, lab1)] | (lab1, mut1, arg1)::rem1, (lab2, mut2, arg2)::rem2 -> - if lab1 <> lab2 then [Field_names (n, lab1, lab2)] else - if mut1 <> mut2 then [Field_mutable lab1] else + if Ident.name lab1 <> Ident.name lab2 + then [Field_names (n, lab1, lab2)] + else if mut1 <> mut2 then [Field_mutable lab1] else if Ctype.equal env true (arg1::decl1.type_params) (arg2::decl2.type_params) then compare_records env decl1 decl2 (n+1) rem1 rem2 else [Field_type lab1] -let type_declarations env id decl1 decl2 = +let type_declarations ?(equality = false) env name decl1 id decl2 = if decl1.type_arity <> decl2.type_arity then [Arity] else if not (private_flags decl1 decl2) then [Privacy] else let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> [] | (Type_variant cstrs1, Type_variant cstrs2) -> - let name = Ident.name id in - if decl1.type_private = Private || decl2.type_private = Public then + let mark cstrs usage name decl = List.iter - (fun (c, _, _) -> Env.mark_constructor_used name decl1 c) - cstrs1; + (fun (c, _, _) -> + Env.mark_constructor_used usage name decl (Ident.name c)) + cstrs + in + let usage = + if decl1.type_private = Private || decl2.type_private = Public + then Env.Positive else Env.Privatize + in + mark cstrs1 usage name decl1; + if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; compare_variants env decl1 decl2 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> let err = compare_records env decl1 decl2 1 labels1 labels2 in @@ -253,7 +263,8 @@ 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.exn_args ed2.exn_args + 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 = diff --git a/typing/includecore.mli b/typing/includecore.mli index 66bd04c310..8ddfcb1631 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -14,8 +14,8 @@ (* Inclusion checks for the core language *) -open Types open Typedtree +open Types exception Dont_match @@ -26,18 +26,19 @@ type type_mismatch = | Constraint | Manifest | Variance - | Field_type of string - | Field_mutable of string - | Field_arity of string - | Field_names of int * string * string - | Field_missing of bool * string + | Field_type of Ident.t + | Field_mutable of Ident.t + | Field_arity of Ident.t + | Field_names of int * Ident.t * Ident.t + | Field_missing of bool * Ident.t | Record_representation of bool 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 + ?equality:bool -> + 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 4cc2904087..367938a920 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -16,8 +16,8 @@ open Misc open Path -open Types open Typedtree +open Types type symptom = Missing_field of Ident.t @@ -31,7 +31,7 @@ type symptom = | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of - Ident.t * cltype_declaration * cltype_declaration * + Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * @@ -63,13 +63,13 @@ let value_descriptions env cxt subst id vd1 vd2 = 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 + 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 cxt subst id decl1 decl2 = - Env.mark_exception_used decl1 (Ident.name id); + Env.mark_exception_used Env.Positive decl1 (Ident.name id); let decl2 = Subst.exception_declaration subst decl2 in if Includecore.exception_declarations env decl1 decl2 then () @@ -112,13 +112,13 @@ type field_desc = | Field_classtype of string let item_ident_name = function - Tsig_value(id, _) -> (id, Field_value(Ident.name id)) - | Tsig_type(id, _, _) -> (id, Field_type(Ident.name id)) - | Tsig_exception(id, _) -> (id, Field_exception(Ident.name id)) - | Tsig_module(id, _, _) -> (id, Field_module(Ident.name id)) - | Tsig_modtype(id, _) -> (id, Field_modtype(Ident.name id)) - | Tsig_class(id, _, _) -> (id, Field_class(Ident.name id)) - | Tsig_cltype(id, _, _) -> (id, Field_classtype(Ident.name id)) + Sig_value(id, _) -> (id, Field_value(Ident.name id)) + | Sig_type(id, _, _) -> (id, Field_type(Ident.name id)) + | Sig_exception(id, _) -> (id, Field_exception(Ident.name id)) + | Sig_module(id, _, _) -> (id, Field_module(Ident.name id)) + | Sig_modtype(id, _) -> (id, Field_modtype(Ident.name id)) + | Sig_class(id, _, _) -> (id, Field_class(Ident.name id)) + | Sig_class_type(id, _, _) -> (id, Field_classtype(Ident.name id)) (* Simplify a structure coercion *) @@ -148,13 +148,13 @@ let rec modtypes env cxt subst mty1 mty2 = and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with - (_, Tmty_ident p2) -> + (_, Mty_ident p2) -> try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) - | (Tmty_ident p1, _) -> + | (Mty_ident p1, _) -> try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 - | (Tmty_signature sig1, Tmty_signature sig2) -> + | (Mty_signature sig1, Mty_signature sig2) -> signatures env cxt subst sig1 sig2 - | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) -> + | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) -> let arg2' = Subst.modtype subst arg2 in let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in let cc_res = @@ -170,9 +170,9 @@ and try_modtypes env cxt subst 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 -> + (Mty_ident p1, Mty_ident p2) when Path.same p1 p2 -> Tcoerce_none - | (_, Tmty_ident p2) -> + | (_, Mty_ident p2) -> try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2) | (_, _) -> assert false @@ -182,7 +182,7 @@ and try_modtypes2 env cxt mty1 mty2 = and signatures env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = - Env.add_signature sig1 env in + 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 @@ -191,14 +191,14 @@ and signatures env cxt subst sig1 sig2 = let (id, name) = item_ident_name item in let nextpos = match item with - Tsig_value(_,{val_kind = Val_prim _}) - | Tsig_type(_,_,_) - | Tsig_modtype(_,_) - | Tsig_cltype(_,_,_) -> pos - | Tsig_value(_,_) - | Tsig_exception(_,_) - | Tsig_module(_,_,_) - | Tsig_class(_, _,_) -> pos+1 in + Sig_value(_,{val_kind = Val_prim _}) + | Sig_type(_,_,_) + | Sig_modtype(_,_) + | Sig_class_type(_,_,_) -> pos + | Sig_value(_,_) + | Sig_exception(_,_) + | Sig_module(_,_,_) + | Sig_class(_, _,_) -> pos+1 in build_component_table nextpos (Tbl.add name (id, item, pos) tbl) rem in let comps1 = @@ -218,7 +218,7 @@ and signatures env cxt subst sig1 sig2 = let (id2, name2) = item_ident_name item2 in let name2, report = match item2, name2 with - Tsig_type (_, {type_manifest=None}, _), Field_type s + Sig_type (_, {type_manifest=None}, _), Field_type s when let l = String.length s in l >= 4 && String.sub s (l-4) 4 = "#row" -> (* Do not report in case of failure, @@ -230,13 +230,13 @@ and signatures env cxt subst sig1 sig2 = let (id1, item1, pos1) = Tbl.find name2 comps1 in let new_subst = match item2 with - Tsig_type _ -> + Sig_type _ -> Subst.add_type id2 (Pident id1) subst - | Tsig_module _ -> + | Sig_module _ -> Subst.add_module id2 (Pident id1) subst - | Tsig_modtype _ -> - Subst.add_modtype id2 (Tmty_ident (Pident id1)) subst - | Tsig_value _ | Tsig_exception _ | Tsig_class _ | Tsig_cltype _ -> + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Pident id1)) subst + | Sig_value _ | Sig_exception _ | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst @@ -253,31 +253,32 @@ and signatures env cxt subst sig1 sig2 = and signature_components env cxt subst = function [] -> [] - | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem -> + | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem -> let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with 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 -> + | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem -> type_declarations env cxt subst id1 tydecl1 tydecl2; signature_components env cxt subst rem - | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos) + | (Sig_exception(id1, excdecl1), Sig_exception(id2, excdecl2), pos) :: 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 -> + | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> let cc = 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 -> + | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: 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 -> + | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: 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 -> + | (Sig_class_type(id1, info1, _), + Sig_class_type(id2, info2, _), pos) :: rem -> class_type_declarations env cxt subst id1 info1 info2; signature_components env cxt subst rem | _ -> @@ -290,12 +291,12 @@ and modtype_infos env cxt subst id info1 info2 = 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) -> + (Modtype_abstract, Modtype_abstract) -> () + | (Modtype_manifest mty1, Modtype_abstract) -> () + | (Modtype_manifest mty1, Modtype_manifest mty2) -> check_modtype_equiv env cxt' mty1 mty2 - | (Tmodtype_abstract, Tmodtype_manifest mty2) -> - check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2 + | (Modtype_abstract, Modtype_manifest mty2) -> + check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2 with Error reasons -> raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons)) diff --git a/typing/includemod.mli b/typing/includemod.mli index c1c9c1f0c0..c060a580a8 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -14,8 +14,8 @@ (* Inclusion checks for the module language *) -open Types open Typedtree +open Types open Format val modtypes: Env.t -> module_type -> module_type -> module_coercion @@ -36,7 +36,7 @@ type symptom = | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of - Ident.t * cltype_declaration * cltype_declaration * + Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * diff --git a/typing/joinmatching.ml b/typing/joinmatching.ml index ccd0e13e08..411f04cfe3 100644 --- a/typing/joinmatching.ml +++ b/typing/joinmatching.ml @@ -23,12 +23,14 @@ open Typedtree -(* Nul process *) +(* Null process *) let null_ex = { exp_desc = Texp_null; exp_loc = Location.none; exp_type = Ctype.none; - exp_env = Env.empty ; } + exp_env = Env.empty ; + exp_extra = []; (* who knows? *) + } (* omega pattern *) let null_pat = Parmatch.omega @@ -124,8 +126,9 @@ let rewrite_simple_one id reac = | None -> reac | Some (rem, found) -> let (jid, pat) = found.jpat_desc in - let xi = Ident.create ("_"^Ident.name jid.jident_desc) in - let xi_pat = {pat with pat_desc = Tpat_var xi} in + let xname = "_"^Ident.name jid.jident_desc in + let xi = Ident.create xname in + let xi_pat = {pat with pat_desc = Tpat_var (xi,mknoloc xname)} in old, (rem, [{found with jpat_desc = (jid, xi_pat)}]::already_done), (xi, pat)::gd @@ -142,8 +145,9 @@ let rewrite_one id dag node2id reac = | None -> reac | Some (rem, found) -> let (jid, pat) = found.jpat_desc in - let xi = Ident.create ("_"^Ident.name jid.jident_desc) in - let xi_pat = {pat with pat_desc = Tpat_var xi} in + let xname = "_"^Ident.name jid.jident_desc in + let xi = Ident.create xname in + let xi_pat = {pat with pat_desc = Tpat_var (xi,mknoloc xname)} in let new_or_jpats = let nodes = Agraph.nodes dag in let has_info n = eq_pat (Agraph.info dag n) pat in diff --git a/typing/mtype.ml b/typing/mtype.ml index 5700b59e0e..cda8186db5 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -21,7 +21,7 @@ open Types let rec scrape env mty = match mty with - Tmty_ident p -> + Mty_ident p -> begin try scrape env (Env.find_modtype_expansion p env) with Not_found -> @@ -34,19 +34,19 @@ let freshen mty = let rec strengthen env mty p = match scrape env mty with - Tmty_signature sg -> - Tmty_signature(strengthen_sig env sg p) - | Tmty_functor(param, arg, res) when !Clflags.applicative_functors -> - Tmty_functor(param, arg, strengthen env res (Papply(p, Pident param))) + Mty_signature sg -> + Mty_signature(strengthen_sig env sg p) + | Mty_functor(param, arg, res) when !Clflags.applicative_functors -> + Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty and strengthen_sig env sg p = match sg with [] -> [] - | (Tsig_value(id, desc) as sigelt) :: rem -> + | (Sig_value(id, desc) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | Tsig_type(id, decl, rs) :: rem -> + | Sig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with Some _, Public, _ -> decl @@ -60,26 +60,26 @@ and strengthen_sig env sg p = else { decl with type_manifest = manif } in - Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p - | (Tsig_exception(id, d) as sigelt) :: rem -> + Sig_type(id, newdecl, rs) :: strengthen_sig env rem p + | (Sig_exception(id, d) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | Tsig_module(id, mty, rs) :: rem -> - Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs) + | Sig_module(id, mty, rs) :: rem -> + Sig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs) :: strengthen_sig (Env.add_module id mty env) rem p (* Need to add the module in case it defines manifest module types *) - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> let newdecl = match decl with - Tmodtype_abstract -> - Tmodtype_manifest(Tmty_ident(Pdot(p, Ident.name id, nopos))) - | Tmodtype_manifest _ -> + Modtype_abstract -> + Modtype_manifest(Mty_ident(Pdot(p, Ident.name id, nopos))) + | Modtype_manifest _ -> decl in - Tsig_modtype(id, newdecl) :: + Sig_modtype(id, newdecl) :: strengthen_sig (Env.add_modtype id decl env) rem p (* Need to add the module type in case it is manifest *) - | (Tsig_class(id, decl, rs) as sigelt) :: rem -> + | (Sig_class(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | (Tsig_cltype(id, decl, rs) as sigelt) :: rem -> + | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p (* In nondep_supertype, env is only used for the type it assigns to id. @@ -92,16 +92,16 @@ let nondep_supertype env mid mty = let rec nondep_mty env va mty = match mty with - Tmty_ident p -> + Mty_ident p -> if Path.isfree mid p then nondep_mty env va (Env.find_modtype_expansion p env) else mty - | Tmty_signature sg -> - Tmty_signature(nondep_sig env va sg) - | Tmty_functor(param, arg, res) -> + | Mty_signature sg -> + Mty_signature(nondep_sig env va sg) + | Mty_functor(param, arg, res) -> let var_inv = match va with Co -> Contra | Contra -> Co | Strict -> Strict in - Tmty_functor(param, nondep_mty env var_inv arg, + Mty_functor(param, nondep_mty env var_inv arg, nondep_mty (Env.add_module param arg env) va res) and nondep_sig env va = function @@ -109,38 +109,38 @@ let nondep_supertype env mid mty = | item :: rem -> let rem' = nondep_sig env va rem in match item with - Tsig_value(id, d) -> - Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type; + Sig_value(id, d) -> + Sig_value(id, {val_type = Ctype.nondep_type env mid d.val_type; 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' + | Sig_type(id, d, rs) -> + Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' - | Tsig_exception(id, d) -> + | Sig_exception(id, d) -> 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) -> + Sig_exception(id, d) :: rem' + | Sig_module(id, mty, rs) -> + Sig_module(id, nondep_mty env va mty, rs) :: rem' + | Sig_modtype(id, d) -> begin try - Tsig_modtype(id, nondep_modtype_decl env d) :: rem' + Sig_modtype(id, nondep_modtype_decl env d) :: rem' with Not_found -> match va with - Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem' + Co -> Sig_modtype(id, Modtype_abstract) :: rem' | _ -> raise Not_found end - | Tsig_class(id, d, rs) -> - Tsig_class(id, Ctype.nondep_class_declaration env mid d, rs) + | Sig_class(id, d, rs) -> + Sig_class(id, Ctype.nondep_class_declaration env mid d, rs) :: rem' - | Tsig_cltype(id, d, rs) -> - Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d, rs) + | Sig_class_type(id, d, rs) -> + Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs) :: rem' and nondep_modtype_decl env = function - Tmodtype_abstract -> Tmodtype_abstract - | Tmodtype_manifest mty -> Tmodtype_manifest(nondep_mty env Strict mty) + Modtype_abstract -> Modtype_abstract + | Modtype_manifest mty -> Modtype_manifest(nondep_mty env Strict mty) in nondep_mty env Co mty @@ -160,62 +160,62 @@ let enrich_typedecl env p decl = let rec enrich_modtype env p mty = match mty with - Tmty_signature sg -> - Tmty_signature(List.map (enrich_item env p) sg) + Mty_signature sg -> + Mty_signature(List.map (enrich_item env p) sg) | _ -> mty and enrich_item env p = function - Tsig_type(id, decl, rs) -> - Tsig_type(id, + Sig_type(id, decl, rs) -> + Sig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) - | Tsig_module(id, mty, rs) -> - Tsig_module(id, + | Sig_module(id, mty, rs) -> + Sig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs) | item -> item let rec type_paths env p mty = match scrape env mty with - Tmty_ident p -> [] - | Tmty_signature sg -> type_paths_sig env p 0 sg - | Tmty_functor(param, arg, res) -> [] + Mty_ident p -> [] + | Mty_signature sg -> type_paths_sig env p 0 sg + | Mty_functor(param, arg, res) -> [] and type_paths_sig env p pos sg = match sg with [] -> [] - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in type_paths_sig env p pos' rem - | Tsig_type(id, decl, _) :: rem -> + | Sig_type(id, decl, _) :: rem -> Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> type_paths env (Pdot(p, Ident.name id, pos)) mty @ type_paths_sig (Env.add_module id mty env) p (pos+1) rem - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> type_paths_sig (Env.add_modtype id decl env) p pos rem - | (Tsig_exception _ | Tsig_class _) :: rem -> + | (Sig_exception _ | Sig_class _) :: rem -> type_paths_sig env p (pos+1) rem - | (Tsig_cltype _) :: rem -> + | (Sig_class_type _) :: rem -> type_paths_sig env p pos rem let rec no_code_needed env mty = match scrape env mty with - Tmty_ident p -> false - | Tmty_signature sg -> no_code_needed_sig env sg - | Tmty_functor(_, _, _) -> false + Mty_ident p -> false + | Mty_signature sg -> no_code_needed_sig env sg + | Mty_functor(_, _, _) -> false and no_code_needed_sig env sg = match sg with [] -> true - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> begin match decl.val_kind with | Val_prim _ -> no_code_needed_sig env rem | _ -> false end - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> no_code_needed env mty && no_code_needed_sig (Env.add_module id mty env) rem - | (Tsig_type _ | Tsig_modtype _ | Tsig_cltype _) :: rem -> + | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> no_code_needed_sig env rem - | (Tsig_exception _ | Tsig_class _) :: rem -> + | (Sig_exception _ | Sig_class _) :: rem -> false diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 0596a01378..e1578b9285 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -24,13 +24,15 @@ open Typedtree (*************************************) let make_pat desc ty tenv = - {pat_desc = desc; pat_loc = Location.none; + {pat_desc = desc; pat_loc = Location.none; pat_extra = []; pat_type = ty ; pat_env = tenv } let omega = make_pat Tpat_any Ctype.none Env.empty let extra_pat = - make_pat (Tpat_var (Ident.create "+")) Ctype.none Env.empty + make_pat + (Tpat_var (Ident.create "+", mknoloc "+")) + Ctype.none Env.empty let rec omegas i = if i <= 0 then [] else omega :: omegas (i-1) @@ -55,9 +57,9 @@ let records_args l1 l2 = (* Invariant: fields are already sorted by Typecore.type_label_a_list *) let rec combine r1 r2 l1 l2 = match l1,l2 with | [],[] -> List.rev r1, List.rev r2 - | [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 - | (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] - | (lbl1,p1)::rem1, (lbl2,p2)::rem2 -> + | [],(_,_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 + | (_,_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] + | (_,_,lbl1,p1)::rem1, (_, _,lbl2,p2)::rem2 -> if lbl1.lbl_pos < lbl2.lbl_pos then combine (p1::r1) (omega::r2) rem1 l2 else if lbl1.lbl_pos > lbl2.lbl_pos then @@ -69,8 +71,8 @@ let records_args l1 l2 = let rec compat p q = match p.pat_desc,q.pat_desc with - | Tpat_alias (p,_),_ -> compat p q - | _,Tpat_alias (q,_) -> compat p q + | Tpat_alias (p,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_) -> compat p q | (Tpat_any|Tpat_var _),_ -> true | _,(Tpat_any|Tpat_var _) -> true | Tpat_or (p1,p2,_),_ -> compat p1 q || compat p2 q @@ -78,7 +80,7 @@ let rec compat p q = | Tpat_constant c1, Tpat_constant c2 -> c1=c2 | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs | Tpat_lazy p, Tpat_lazy q -> compat p q - | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) -> + | Tpat_construct (_, _, c1,ps1, _), Tpat_construct (_, _, c2,ps2, _) -> c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) -> l1=l2 && compat p1 p2 @@ -86,7 +88,7 @@ let rec compat p q = l1 = l2 | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false - | Tpat_record l1,Tpat_record l2 -> + | Tpat_record (l1,_),Tpat_record (l2,_) -> let ps,qs = records_args l1 l2 in compats ps qs | Tpat_array ps, Tpat_array qs -> @@ -135,7 +137,7 @@ let find_label lbl lbls = try let name,_,_ = List.nth lbls lbl.lbl_pos in name - with Failure "nth" -> "*Unkown label*" + with Failure "nth" -> Ident.create "*Unknown label*" let rec get_record_labels ty tenv = match get_type_descr ty tenv with @@ -156,7 +158,7 @@ let get_constr_name tag ty tenv = match tag with | Cstr_exception (path, _) -> Path.name path | _ -> try - let name,_,_ = get_constr tag ty tenv in name + let name,_,_ = get_constr tag ty tenv in Ident.name name with | Datarepr.Constr_not_found -> "*Unknown constructor*" @@ -165,9 +167,21 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with | _ -> false -let rec pretty_val ppf v = match v.pat_desc with +let rec pretty_val ppf v = + match v.pat_extra with + (cstr,_) :: rem -> + begin match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } + | Tpat_constraint ctyp -> + fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } + end + | [] -> + match v.pat_desc with | Tpat_any -> fprintf ppf "_" - | Tpat_var x -> Ident.print ppf x + | Tpat_var (x,_) -> Ident.print ppf x | Tpat_constant (Const_int i) -> fprintf ppf "%d" i | Tpat_constant (Const_char c) -> fprintf ppf "%C" c | Tpat_constant (Const_string s) -> fprintf ppf "%S" s @@ -177,13 +191,13 @@ let rec pretty_val ppf v = match v.pat_desc with | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct ({cstr_tag=tag},[]) -> + | Tpat_construct (_, _, {cstr_tag=tag},[], _) -> let name = get_constr_name tag v.pat_type v.pat_env in fprintf ppf "%s" name - | Tpat_construct ({cstr_tag=tag},[w]) -> + | Tpat_construct (_, _, {cstr_tag=tag},[w], _) -> let name = get_constr_name tag v.pat_type v.pat_env in fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w - | Tpat_construct ({cstr_tag=tag},vs) -> + | Tpat_construct (_, _, {cstr_tag=tag},vs, _) -> let name = get_constr_name tag v.pat_type v.pat_env in begin match (name, vs) with ("::", [v1;v2]) -> @@ -195,36 +209,36 @@ let rec pretty_val ppf v = match v.pat_desc with fprintf ppf "`%s" l | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w - | Tpat_record lvs -> + | Tpat_record (lvs,_) -> fprintf ppf "@[{%a}@]" (pretty_lvals (get_record_labels v.pat_type v.pat_env)) (List.filter (function - | (_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) + | (_,_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) | _ -> true) lvs) | Tpat_array vs -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v,x) -> + | Tpat_alias (v, x,_) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_or (v,w,_) -> fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w and pretty_car ppf v = match v.pat_desc with -| Tpat_construct ({cstr_tag=tag}, [_ ; _]) +| Tpat_construct (_,_,{cstr_tag=tag}, [_ ; _], _) when is_cons tag v -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct ({cstr_tag=tag}, [v1 ; v2]) +| Tpat_construct (_,_,{cstr_tag=tag}, [v1 ; v2], _) when is_cons tag v -> fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 | _ -> pretty_val ppf v and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_::_) -> fprintf ppf "(%a)" pretty_val v +| Tpat_construct (_,_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_or ppf v = match v.pat_desc with @@ -240,12 +254,13 @@ and pretty_vals sep ppf = function and pretty_lvals lbls ppf = function | [] -> () - | [lbl,v] -> + | [_, _,lbl,v] -> let name = find_label lbl lbls in - fprintf ppf "%s=%a" name pretty_val v - | (lbl,v)::rest -> + fprintf ppf "%s=%a" (Ident.name name) pretty_val v + | (_, _, lbl,v)::rest -> let name = find_label lbl lbls in - fprintf ppf "%s=%a;@ %a" name pretty_val v (pretty_lvals lbls) rest + fprintf ppf "%s=%a;@ %a" + (Ident.name name) pretty_val v (pretty_lvals lbls) rest let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v @@ -263,7 +278,7 @@ let prerr_pat v = (* Check top matching *) let simple_match p1 p2 = match p1.pat_desc, p2.pat_desc with - | Tpat_construct(c1, _), Tpat_construct(c2, _) -> + | Tpat_construct(_, _, c1, _, _), Tpat_construct(_,_, c2, _, _) -> c1.cstr_tag = c2.cstr_tag | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) -> l1 = l2 @@ -283,30 +298,32 @@ let simple_match p1 p2 = (* extract record fields as a whole *) let record_arg p = match p.pat_desc with | Tpat_any -> [] -| Tpat_record args -> args +| Tpat_record (args,_) -> args | _ -> fatal_error "Parmatch.as_record" (* Raise Not_found when pos is not present in arg *) let get_field pos arg = - let _,p = List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg in + let _,_,_, p = List.find (fun (_,_,lbl,_) -> pos = lbl.lbl_pos) arg in p let extract_fields omegas arg = List.map - (fun (lbl,_) -> + (fun (_,_,lbl,_) -> try get_field lbl.lbl_pos arg with Not_found -> omega) omegas let all_record_args lbls = match lbls with -| ({lbl_all=lbl_all},_)::_ -> +| (_,_,{lbl_all=lbl_all},_)::_ -> let t = Array.map - (fun lbl -> lbl,omega) lbl_all in + (fun lbl -> Path.Pident (Ident.create "?temp?"), + mknoloc (Longident.Lident "?temp?"), lbl,omega) + lbl_all in List.iter - (fun ((lbl,_) as x) -> t.(lbl.lbl_pos) <- x) + (fun ((_,_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) lbls ; Array.to_list t | _ -> fatal_error "Parmatch.all_record_args" @@ -314,19 +331,19 @@ let all_record_args lbls = match lbls with (* Build argument list when p2 >= p1, where p1 is a simple pattern *) let rec simple_match_args p1 p2 = match p2.pat_desc with -| Tpat_alias (p2,_) -> simple_match_args p1 p2 -| Tpat_construct(cstr, args) -> args +| Tpat_alias (p2,_,_) -> simple_match_args p1 p2 +| Tpat_construct(_,_, cstr, args, _) -> args | Tpat_variant(lab, Some arg, _) -> [arg] | Tpat_tuple(args) -> args -| Tpat_record(args) -> extract_fields (record_arg p1) args +| Tpat_record(args,_) -> extract_fields (record_arg p1) args | Tpat_array(args) -> args | Tpat_lazy arg -> [arg] | (Tpat_any | Tpat_var(_)) -> begin match p1.pat_desc with - Tpat_construct(_, args) -> omega_list args + Tpat_construct(_,_, _,args, _) -> omega_list args | Tpat_variant(_, Some _, _) -> [omega] | Tpat_tuple(args) -> omega_list args - | Tpat_record(args) -> omega_list args + | Tpat_record(args,_) -> omega_list args | Tpat_array(args) -> omega_list args | Tpat_lazy _ -> [omega] | _ -> [] @@ -341,24 +358,27 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with let rec normalize_pat q = match q.pat_desc with | Tpat_any | Tpat_constant _ -> q | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env - | Tpat_alias (p,_) -> normalize_pat p + | Tpat_alias (p,_,_) -> normalize_pat p | Tpat_tuple (args) -> make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env - | Tpat_construct (c,args) -> - make_pat (Tpat_construct (c,omega_list args)) q.pat_type q.pat_env + | Tpat_construct (lid, lid_loc, c,args,explicit_arity) -> + make_pat + (Tpat_construct (lid, lid_loc, c,omega_list args, explicit_arity)) + q.pat_type q.pat_env | Tpat_variant (l, arg, row) -> make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row)) q.pat_type q.pat_env | Tpat_array (args) -> make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env - | Tpat_record (largs) -> - make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs)) + | Tpat_record (largs, closed) -> + make_pat + (Tpat_record (List.map (fun (lid,lid_loc,lbl,_) -> + lid, lid_loc, lbl,omega) largs, closed)) q.pat_type q.pat_env | Tpat_lazy _ -> make_pat (Tpat_lazy omega) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" - (* Build normalized (cf. supra) discriminating pattern, in the non-data type case @@ -367,7 +387,7 @@ let rec normalize_pat q = match q.pat_desc with let discr_pat q pss = let rec acc_pat acc pss = match pss with - ({pat_desc = Tpat_alias (p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss -> acc_pat acc ((p::ps)::pss) | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss -> acc_pat acc ((p1::ps)::(p2::ps)::pss) @@ -375,19 +395,19 @@ let discr_pat q pss = acc_pat acc pss | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p - | (({pat_desc = Tpat_record largs} as p)::_)::pss -> + | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss -> let new_omegas = List.fold_right - (fun (lbl,_) r -> + (fun (lid, lid_loc, lbl,_) r -> try let _ = get_field lbl.lbl_pos r in r with Not_found -> - (lbl,omega)::r) + (lid, lid_loc, lbl,omega)::r) largs (record_arg acc) in acc_pat - (make_pat (Tpat_record new_omegas) p.pat_type p.pat_env) + (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) pss | _ -> acc in @@ -412,26 +432,27 @@ let do_set_args erase_mutable q r = match q with | {pat_desc = Tpat_tuple omegas} -> let args,rest = read_args omegas r in make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest -| {pat_desc = Tpat_record omegas} -> +| {pat_desc = Tpat_record (omegas,closed)} -> let args,rest = read_args omegas r in make_pat (Tpat_record - (List.map2 (fun (lbl,_) arg -> + (List.map2 (fun (lid, lid_loc, lbl,_) arg -> if erase_mutable && (match lbl.lbl_mut with | Mutable -> true | Immutable -> false) then - lbl, omega + lid, lid_loc, lbl, omega else - lbl,arg) - omegas args)) + lid, lid_loc, lbl, arg) + omegas args, closed)) q.pat_type q.pat_env:: rest -| {pat_desc = Tpat_construct (c,omegas)} -> +| {pat_desc = Tpat_construct (lid, lid_loc, c,omegas, explicit_arity)} -> let args,rest = read_args omegas r in make_pat - (Tpat_construct (c,args)) q.pat_type q.pat_env:: + (Tpat_construct (lid, lid_loc, c,args, explicit_arity)) + q.pat_type q.pat_env:: rest | {pat_desc = Tpat_variant (l, omega, row)} -> let arg, rest = @@ -464,7 +485,7 @@ and set_args_erase_mutable q r = do_set_args true q r (* filter pss acording to pattern q *) let filter_one q pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_rec ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec ((p1::ps)::(p2::ps)::pss) @@ -482,7 +503,7 @@ let filter_one q pss = *) let filter_extra pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_rec ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec ((p1::ps)::(p2::ps)::pss) @@ -517,7 +538,7 @@ let filter_all pat0 pss = else c :: insert q qs env in let rec filter_rec env = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_rec env ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec env ((p1::ps)::(p2::ps)::pss) @@ -528,13 +549,14 @@ let filter_all pat0 pss = | _ -> env and filter_omega env = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_omega env ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_omega env ((p1::ps)::(p2::ps)::pss) | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss -> filter_omega - (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) env) + (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) + env) pss | _::pss -> filter_omega env pss | [] -> env in @@ -556,7 +578,7 @@ let rec set_last a = function (* mark constructor lines for failure when they are incomplete *) let rec mark_partial = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> mark_partial ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> mark_partial ((p1::ps)::(p2::ps)::pss) @@ -596,14 +618,14 @@ let row_of_pat pat = not. *) -let generalized_constructor x = - match x with - ({pat_desc = Tpat_construct(c,_);pat_env=env},_) -> +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 = +let clean_env env = + let rec loop = function | [] -> [] | x :: xs -> @@ -612,12 +634,13 @@ let clean_env env = loop env let full_match ignore_generalized closing env = match env with -| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> +| ({pat_desc = Tpat_construct (_,_,{cstr_tag=Cstr_exception _},_,_)},_)::_ -> false -| ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> +| ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ -> if ignore_generalized then - (* remove generalized constructors; those cases will be handled separately *) - let env = clean_env env in + (* 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 @@ -630,7 +653,7 @@ let full_match ignore_generalized closing env = match env with env in let row = row_of_pat p in - if closing && not row.row_fixed then + if closing && not (Btype.row_fixed row) then (* closing=true, we are considering the variant as closed *) List.for_all (fun (tag,f) -> @@ -656,12 +679,13 @@ let full_match ignore_generalized closing env = match env with | _ -> fatal_error "Parmatch.full_match" let full_match_gadt env = match env with - | ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> + | ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ -> List.length env = c.cstr_consts + c.cstr_nonconsts | _ -> true let extendable_match env = match env with -| ({pat_desc = Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ -> +| ({pat_desc=Tpat_construct(_,_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)} + as p,_) :: _ -> let path = get_type_path p.pat_type p.pat_env in not (Path.same path Predef.path_bool || @@ -673,9 +697,9 @@ let extendable_match env = match env with let should_extend ext env = match ext with | None -> false | Some ext -> match env with - | ({pat_desc = - Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) - :: _ -> + | ({pat_desc = + Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)} + as p, _) :: _ -> let path = get_type_path p.pat_type p.pat_env in Path.same path ext | _ -> false @@ -703,7 +727,10 @@ let complete_tags nconsts nconstrs tags = (* build a pattern from a constructor list *) let pat_of_constr ex_pat cstr = - {ex_pat with pat_desc = Tpat_construct (cstr,omegas cstr.cstr_arity)} + {ex_pat with pat_desc = + Tpat_construct (Path.Pident (Ident.create "?pat_of_constr?"), + mknoloc (Longident.Lident "?pat_of_constr?"), + cstr,omegas cstr.cstr_arity,false)} let rec pat_of_constrs ex_pat = function | [] -> raise Empty @@ -729,7 +756,7 @@ let rec adt_path env ty = | _ -> raise Not_an_adt ;; -let rec map_filter f = +let rec map_filter f = function [] -> [] | x :: xs -> @@ -738,12 +765,13 @@ let rec map_filter f = | Some y -> y :: map_filter f xs (* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs p all_tags = +let complete_constrs p all_tags = match p.pat_desc with - | Tpat_construct (c,_) -> + | Tpat_construct (_,_,c,_,_) -> begin try let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in - let constrs = Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in + let constrs = + Env.find_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) @@ -771,22 +799,23 @@ let build_other_constant proj make first next p env = *) let build_other ext env = match env with -| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) +| ({pat_desc = + Tpat_construct (lid, lid_loc, ({cstr_tag=Cstr_exception _} as c),_,_)},_) ::_ -> make_pat (Tpat_construct - ({c with + (lid, lid_loc, {c with cstr_tag=(Cstr_exception (Path.Pident (Ident.create "*exception*"), Location.none))}, - [])) + [], false)) Ctype.none Env.empty -| ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ -> +| ({pat_desc = Tpat_construct (_,_, _,_,_)} as p,_) :: _ -> begin match ext with | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> extra_pat | _ -> let get_tag = function - | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag + | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag | _ -> fatal_error "Parmatch.get_tag" in let all_tags = List.map (fun (p,_) -> get_tag p) env in pat_of_constrs p (complete_constrs p all_tags) @@ -899,11 +928,11 @@ let build_other ext env = match env with | [] -> omega | _ -> omega -let build_other_gadt ext env = +let build_other_gadt ext env = match env with - | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ -> + | ({pat_desc = Tpat_construct _} as p,_) :: _ -> let get_tag = function - | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag + | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag | _ -> fatal_error "Parmatch.get_tag" in let all_tags = List.map (fun (p,_) -> get_tag p) env in let cnstrs = complete_constrs p all_tags in @@ -912,7 +941,7 @@ let build_other_gadt ext env = Format.eprintf "@.@."; *) pats | _ -> assert false - + (* Core function : Is the last row of pattern matrix pss + qs satisfiable ? @@ -925,11 +954,14 @@ let build_other_gadt ext env = let rec has_instance p = match p.pat_desc with | Tpat_variant (l,_,r) when is_absent l r -> false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 - | Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps - | Tpat_record lps -> has_instances (List.map snd lps) - | Tpat_lazy p -> has_instance p + | Tpat_construct (_, _,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> + has_instances ps + | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,_,x) -> x) lps) + | Tpat_lazy p + -> has_instance p + and has_instances = function | [] -> true @@ -942,7 +974,7 @@ let rec satisfiable pss qs = match pss with | [] -> false | {pat_desc = Tpat_or(q1,q2,_)}::qs -> satisfiable pss (q1::qs) || satisfiable pss (q2::qs) - | {pat_desc = Tpat_alias(q,_)}::qs -> + | {pat_desc = Tpat_alias(q,_,_)}::qs -> satisfiable pss (q::qs) | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> let q0 = discr_pat omega pss in @@ -976,14 +1008,14 @@ type 'a result = | Rsome of 'a (* This matching value *) let rec orify_many = - let rec orify x y = - make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env + 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 | (p,pss)::rest -> @@ -997,13 +1029,13 @@ let rec try_many_gadt f = function | (p,pss)::rest -> match f (p,pss) with | Rnone -> try_many f rest - | Rsome sofar -> - let others = try_many f rest in + | 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 @@ -1053,8 +1085,8 @@ let rec exhaust ext pss n = match pss with | Empty -> fatal_error "Parmatch.exhaust" end -let combinations f lst lst' = - let rec iter2 x = +let combinations f lst lst' = + let rec iter2 x = function [] -> [] | y :: ys -> @@ -1066,10 +1098,33 @@ let combinations f lst lst' = | x :: xs -> iter2 x lst' @ iter xs in iter lst - + +(* +let print_pat pat = + let rec string_of_pat pat = + match pat.pat_desc with + Tpat_var _ -> "v" + | Tpat_any -> "_" + | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p) + | Tpat_constant n -> "0" + | Tpat_construct (_, lid, _, _) -> + Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt)) + | Tpat_lazy p -> + Printf.sprintf "(lazy %s)" (string_of_pat p) + | Tpat_or (p1,p2,_) -> + Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2) + | Tpat_tuple list -> + Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) + | Tpat_variant (_, _, _) -> "variant" + | Tpat_record (_, _) -> "record" + | Tpat_array _ -> "array" + in + Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) +*) + (* strictly more powerful than exhaust; however, exhaust was kept for backwards compatibility *) -let rec exhaust_gadt ext pss n = match pss with +let rec exhaust_gadt (ext:Path.t option) pss n = match pss with | [] -> Rsome [omegas n] | []::_ -> Rnone | pss -> @@ -1112,34 +1167,33 @@ let rec exhaust_gadt ext pss n = match pss with | Rsome r -> try let missing_trailing = build_other_gadt ext constrs in - let before = - match before with - Rnone -> [] - | Rsome lst -> lst + let before = + match before with + Rnone -> [] + | Rsome lst -> lst in - let dug = + let dug = combinations - (fun head tail -> - head :: tail) + (fun head tail -> head :: tail) missing_trailing r in - Rsome (dug @ before) + 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 +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 + let singletons = + List.map + (function [x] -> x | _ -> assert false) lst @@ -1185,7 +1239,7 @@ let rec pressure_variants tdefs = function begin match constrs, tdefs with ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> let row = row_of_pat p in - if row.row_fixed + if Btype.row_fixed row || pressure_variants None (filter_extra pss) then () else close_variant env row | _ -> () @@ -1205,7 +1259,7 @@ let rec pressure_variants tdefs = function type answer = | Used (* Useful pattern *) | Unused (* Useless pattern *) - | Upartial of Typedtree.pattern list (* Neither, with list of useless pattern *) + | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) let pretty_pat p = @@ -1261,7 +1315,7 @@ let make_rows pss = List.map make_row pss (* Useful to detect and expand or pats inside as pats *) let rec unalias p = match p.pat_desc with -| Tpat_alias (p,_) -> unalias p +| Tpat_alias (p,_,_) -> unalias p | _ -> p @@ -1279,7 +1333,7 @@ let is_var_column rs = (* Standard or-args for left-to-right matching *) let rec or_args p = match p.pat_desc with | Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_) -> or_args p +| Tpat_alias (p,_,_) -> or_args p | _ -> assert false (* Just remove current column *) @@ -1314,7 +1368,7 @@ let filter_one q rs = | r::rem -> match r.active with | [] -> assert false - | {pat_desc = Tpat_alias(p,_)}::ps -> + | {pat_desc = Tpat_alias(p,_,_)}::ps -> filter_rec ({r with active = p::ps}::rem) | {pat_desc = Tpat_or(p1,p2,_)}::ps -> filter_rec @@ -1467,10 +1521,10 @@ and every_both pss qs q1 q2 = let rec le_pat p q = match (p.pat_desc, q.pat_desc) with | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_), _ -> le_pat p q - | _, Tpat_alias(q,_) -> le_pat p q + | Tpat_alias(p,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_) -> le_pat p q | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2 - | Tpat_construct(c1,ps), Tpat_construct(c2,qs) -> + | Tpat_construct(_,_,c1,ps,_), Tpat_construct(_,_,c2,qs,_) -> c1.cstr_tag = c2.cstr_tag && le_pats ps qs | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> (l1 = l2 && le_pat p1 p2) @@ -1479,7 +1533,7 @@ let rec le_pat p q = | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs | Tpat_lazy p, Tpat_lazy q -> le_pat p q - | Tpat_record l1, Tpat_record l2 -> + | Tpat_record (l1,_), Tpat_record (l2,_) -> let ps,qs = records_args l1 l2 in le_pats ps qs | Tpat_array(ps), Tpat_array(qs) -> @@ -1507,8 +1561,8 @@ let get_mins le ps = *) let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_),_ -> lub p q -| _,Tpat_alias (q,_) -> lub p q +| Tpat_alias (p,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_) -> lub p q | (Tpat_any|Tpat_var _),_ -> q | _,(Tpat_any|Tpat_var _) -> p | Tpat_or (p1,p2,_),_ -> orlub p1 p2 q @@ -1520,19 +1574,20 @@ let rec lub p q = match p.pat_desc,q.pat_desc with | Tpat_lazy p, Tpat_lazy q -> let r = lub p q in make_pat (Tpat_lazy r) p.pat_type p.pat_env -| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) +| Tpat_construct (lid, lid_loc, c1,ps1,_), Tpat_construct (_, _,c2,ps2,_) when c1.cstr_tag = c2.cstr_tag -> let rs = lubs ps1 ps2 in - make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env + make_pat (Tpat_construct (lid, lid_loc, c1,rs, false)) + p.pat_type p.pat_env | Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) when l1=l2 -> let r=lub p1 p2 in make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env | Tpat_variant (l1,None,row), Tpat_variant(l2,None,_) when l1 = l2 -> p -| Tpat_record l1,Tpat_record l2 -> +| Tpat_record (l1,closed),Tpat_record (l2,_) -> let rs = record_lubs l1 l2 in - make_pat (Tpat_record rs) p.pat_type p.pat_env + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env | Tpat_array ps, Tpat_array qs when List.length ps = List.length qs -> let rs = lubs ps qs in @@ -1554,13 +1609,13 @@ and record_lubs l1 l2 = let rec lub_rec l1 l2 = match l1,l2 with | [],_ -> l2 | _,[] -> l1 - | (lbl1,p1)::rem1, (lbl2,p2)::rem2 -> + | (lid1, lid1_loc, lbl1,p1)::rem1, (lid2, lid2_loc, lbl2,p2)::rem2 -> if lbl1.lbl_pos < lbl2.lbl_pos then - (lbl1,p1)::lub_rec rem1 l2 + (lid1, lid1_loc, lbl1,p1)::lub_rec rem1 l2 else if lbl2.lbl_pos < lbl1.lbl_pos then - (lbl2,p2)::lub_rec l1 rem2 + (lid2, lid2_loc, lbl2,p2)::lub_rec l1 rem2 else - (lbl1,lub p1 p2)::lub_rec rem1 rem2 in + (lid1, lid1_loc, lbl1,lub p1 p2)::lub_rec rem1 rem2 in lub_rec l1 l2 and lubs ps qs = match ps,qs with @@ -1631,7 +1686,7 @@ let rec do_filter_var = function let do_filter_one q pss = let rec filter_rec = function - | ({pat_desc = Tpat_alias(p,_)}::ps,loc)::pss -> + | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss -> filter_rec ((p::ps,loc)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss -> filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss) @@ -1673,11 +1728,11 @@ let check_partial_all v casel = (************************) - let rec get_first f = + let rec get_first f = function | [] -> None - | x :: xs -> - match f x with + | x :: xs -> + match f x with | None -> get_first f xs | x -> x @@ -1685,11 +1740,11 @@ let check_partial_all v casel = (* conversion from Typedtree.pattern to Parsetree.pattern list *) module Conv = struct open Parsetree - let mkpat desc = + let mkpat desc = {ppat_desc = desc; ppat_loc = Location.none} - let rec select : 'a list list -> 'a list list = + let rec select : 'a list list -> 'a list list = function | xs :: [] -> List.map (fun y -> [y]) xs | (x::xs)::ys -> @@ -1700,48 +1755,49 @@ module Conv = struct select (xs::ys) | _ -> [] - let name_counter = ref 0 - let fresh () = - let current = !name_counter in + 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 = + let conv (typed: Typedtree.pattern) : + Parsetree.pattern list * + (string,Path.t * Types.constructor_description) Hashtbl.t * + (string,Path.t * 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_alias (p,_,_) -> loop p | Tpat_tuple lst -> - let results = select (List.map loop lst) in + 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; + | Tpat_construct (cstr_path, cstr_lid, cstr,lst,_) -> + let id = fresh () in + let lid = { cstr_lid with txt = Longident.Lident id } in + Hashtbl.add constrs id (cstr_path,cstr); let results = select (List.map loop lst) in begin match lst with [] -> - [mkpat (Ppat_construct(Longident.Lident id, None, false))] + [mkpat (Ppat_construct(lid, None, false))] | _ -> - List.map + List.map (fun lst -> - let arg = + let arg = match lst with [] -> assert false | [x] -> Some x | _ -> Some (mkpat (Ppat_tuple lst)) in - mkpat (Ppat_construct(Longident.Lident id, arg, false))) + mkpat (Ppat_construct(lid, arg, false))) results end | Tpat_variant(label,p_opt,row_desc) -> @@ -1749,38 +1805,40 @@ module Conv = struct | None -> [mkpat (Ppat_variant(label, None))] | Some p -> - let results = loop p in + let results = loop p in List.map (fun p -> mkpat (Ppat_variant(label, Some p))) results end - | Tpat_record subpatterns -> - let pats = + | Tpat_record (subpatterns, _closed_flag) -> + let pats = select - (List.map (fun (_,x) -> (loop x)) subpatterns) + (List.map (fun (_,_,_,x) -> (loop x)) subpatterns) in - let label_idents = - List.map - (fun (lbl,_) -> - let id = fresh () in - Hashtbl.add labels id lbl; - Longident.Lident id) + let label_idents = + List.map + (fun (lbl_path,_,lbl,_) -> + let id = fresh () in + Hashtbl.add labels id (lbl_path, lbl); + Longident.Lident id) subpatterns - in + in List.map (fun lst -> - let lst = List.combine label_idents lst in - mkpat (Ppat_record (lst, Open))) + let lst = List.map2 (fun lid pat -> + (mknoloc lid, pat) + ) label_idents lst in + mkpat (Ppat_record (lst, Open))) pats | Tpat_array lst -> - let results = select (List.map loop lst) in + 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 + let results = loop p in List.map (fun p -> mkpat (Ppat_lazy p)) results in - let ps = loop typed in + let ps = loop typed in (ps, constrs, labels) end @@ -1804,10 +1862,14 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with begin match exhaust None pss (List.length ps) with | Rnone -> Total | Rsome [u] -> - let v = - match pred with + let v = + match pred with | Some pred -> - let (patterns,constrs,labels) = Conv.conv u in + let (patterns,constrs,labels) = Conv.conv u in +(* Hashtbl.iter (fun s (path, _) -> + Printf.fprintf stderr "CONV: %s -> %s \n%!" s (Path.name path)) + constrs + ; *) get_first (pred constrs labels) patterns | None -> Some u in @@ -1838,10 +1900,10 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with fatal_error "Parmatch.check_partial" end -let do_check_partial_normal loc casel pss = +let do_check_partial_normal loc casel pss = do_check_partial exhaust loc casel pss -let do_check_partial_gadt pred loc casel pss = +let do_check_partial_gadt pred loc casel pss = do_check_partial ~pred exhaust_gadt loc casel pss @@ -1866,7 +1928,7 @@ let extendable_path path = Path.same path Predef.path_option) let rec collect_paths_from_pat r p = match p.pat_desc with -| Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},ps) -> +| Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) -> let path = get_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat @@ -1874,16 +1936,17 @@ let rec collect_paths_from_pat r p = match p.pat_desc with ps | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r | Tpat_tuple ps | Tpat_array ps -| Tpat_construct ({cstr_tag=Cstr_exception _}, ps)-> +| Tpat_construct (_, _, {cstr_tag=Cstr_exception _}, ps,_)-> List.fold_left collect_paths_from_pat r ps -| Tpat_record lps -> +| Tpat_record (lps,_) -> List.fold_left - (fun r (_,p) -> collect_paths_from_pat r p) + (fun r (_, _, _, p) -> collect_paths_from_pat r p) r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 -| Tpat_lazy p -> +| Tpat_lazy p + -> collect_paths_from_pat r p @@ -1975,16 +2038,19 @@ let useful pats = let rec remove_binders p = match p.pat_desc with | Tpat_any|Tpat_constant _|Tpat_variant (_, None, _) -> p | Tpat_var _ -> { p with pat_desc = Tpat_any } -| Tpat_alias (p, _) -> remove_binders p +| Tpat_alias (p, _, _) -> remove_binders p | Tpat_tuple ps -> { p with pat_desc = Tpat_tuple (remove_binders_list ps) } -| Tpat_construct (c, ps) -> - { p with pat_desc = Tpat_construct (c, remove_binders_list ps) } +| Tpat_construct (path, loc, c, ps, b) -> + { p with pat_desc = Tpat_construct (path, loc, c, remove_binders_list ps, b) } | Tpat_variant (lab, Some p, row) -> { p with pat_desc = Tpat_variant (lab, Some (remove_binders p), row) } -| Tpat_record lblps -> - { p with pat_desc = - Tpat_record (List.map (fun (lbl,p) -> lbl, remove_binders p) lblps) } +| Tpat_record (vrac_ps,fl) -> + let vrac_ps = + List.map + (fun (path,loc,lbl,p) -> path,loc,lbl,remove_binders p) + vrac_ps in + { p with pat_desc = Tpat_record (vrac_ps,fl) } | Tpat_array ps -> { p with pat_desc = Tpat_array (remove_binders_list ps) } | Tpat_or (p1, p2, patho) -> @@ -2012,25 +2078,25 @@ let rec inactive pat = match pat with false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> true -| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps -> +| Tpat_tuple ps | Tpat_construct (_, _, _, ps,_) | Tpat_array ps -> List.for_all (fun p -> inactive p.pat_desc) ps -| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) -> +| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> inactive p.pat_desc -| Tpat_record ldps -> - List.exists (fun (_, p) -> inactive p.pat_desc) ldps +| Tpat_record (ldps,_) -> + List.exists (fun (_, _, _, p) -> inactive p.pat_desc) ldps | Tpat_or (p,q,_) -> inactive p.pat_desc && inactive q.pat_desc - (* A `fluid' pattern is both irrefutable and inactive *) -let fluid pat = irrefutable pat && inactive pat.pat_desc +let fluid pat = irrefutable pat && inactive pat.pat_desc + + - (********************************) (* Exported exhustiveness check *) (********************************) @@ -2040,7 +2106,7 @@ let fluid pat = irrefutable pat && inactive pat.pat_desc on exhaustive matches only. *) -let check_partial_param do_check_partial do_check_fragile loc casel = +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 @@ -2052,11 +2118,11 @@ let check_partial_param do_check_partial do_check_fragile loc casel = end ; total end else - Partial + Partial -let check_partial = - check_partial_param - do_check_partial_normal +let check_partial = + check_partial_param + do_check_partial_normal do_check_fragile_normal let check_partial_gadt pred loc casel = @@ -2064,7 +2130,7 @@ let check_partial_gadt pred loc casel = let first_check = check_partial loc casel in match first_check with | Partial -> Partial - | Total -> + | 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 f3cd2d0876..cd5ca99688 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -13,8 +13,9 @@ (* $Id$ *) (* Detection of partial matches and unused match cases. *) -open Types +open Asttypes open Typedtree +open Types val top_pretty : Format.formatter -> pattern -> unit val pretty_pat : pattern -> unit @@ -26,7 +27,8 @@ val omegas : int -> pattern list val omega_list : 'a list -> pattern list val normalize_pat : pattern -> pattern val all_record_args : - (label_description * pattern) list -> (label_description * pattern) list + (Path.t * Longident.t loc * label_description * pattern) list -> + (Path.t * Longident.t loc * label_description * pattern) list val le_pat : pattern -> pattern -> bool val le_pats : pattern list -> pattern list -> bool @@ -52,10 +54,10 @@ 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) -> +val check_partial_gadt: + ((string,Path.t * constructor_description) Hashtbl.t -> + (string,Path.t * label_description) Hashtbl.t -> + Parsetree.pattern -> pattern option) -> Location.t -> (pattern * expression) list -> partial val check_unused: Env.t -> (pattern * expression) list -> unit diff --git a/typing/predef.ml b/typing/predef.ml index 88091f0903..2f06520b7a 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -19,21 +19,31 @@ open Path open Types open Btype -let ident_int = Ident.create "int" -and ident_char = Ident.create "char" -and ident_string = Ident.create "string" -and ident_float = Ident.create "float" -and ident_bool = Ident.create "bool" -and ident_unit = Ident.create "unit" -and ident_exn = Ident.create "exn" -and ident_array = Ident.create "array" -and ident_list = Ident.create "list" -and ident_format6 = Ident.create "format6" -and ident_option = Ident.create "option" -and ident_nativeint = Ident.create "nativeint" -and ident_int32 = Ident.create "int32" -and ident_int64 = Ident.create "int64" -and ident_lazy_t = Ident.create "lazy_t" +let builtin_idents = ref [] + +let wrap create s = + let id = create s in + builtin_idents := (s, id) :: !builtin_idents; + id + +let ident_create = wrap Ident.create +let ident_create_predef_exn = wrap Ident.create_predef_exn + +let ident_int = ident_create "int" +and ident_char = ident_create "char" +and ident_string = ident_create "string" +and ident_float = ident_create "float" +and ident_bool = ident_create "bool" +and ident_unit = ident_create "unit" +and ident_exn = ident_create "exn" +and ident_array = ident_create "array" +and ident_list = ident_create "list" +and ident_format6 = ident_create "format6" +and ident_option = ident_create "option" +and ident_nativeint = ident_create "nativeint" +and ident_int32 = ident_create "int32" +and ident_int64 = ident_create "int64" +and ident_lazy_t = ident_create "lazy_t" let path_int = Pident ident_int and path_char = Pident ident_char @@ -69,24 +79,31 @@ and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) and type_process kids = newgenty (Tproc kids) (*<JOCAML*) -let ident_match_failure = Ident.create_predef_exn "Match_failure" -and ident_out_of_memory = Ident.create_predef_exn "Out_of_memory" -and ident_invalid_argument = Ident.create_predef_exn "Invalid_argument" -and ident_failure = Ident.create_predef_exn "Failure" -and ident_not_found = Ident.create_predef_exn "Not_found" -and ident_sys_error = Ident.create_predef_exn "Sys_error" -and ident_end_of_file = Ident.create_predef_exn "End_of_file" -and ident_division_by_zero = Ident.create_predef_exn "Division_by_zero" -and ident_stack_overflow = Ident.create_predef_exn "Stack_overflow" -and ident_sys_blocked_io = Ident.create_predef_exn "Sys_blocked_io" -and ident_assert_failure = Ident.create_predef_exn "Assert_failure" +let ident_match_failure = ident_create_predef_exn "Match_failure" +and ident_out_of_memory = ident_create_predef_exn "Out_of_memory" +and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" +and ident_failure = ident_create_predef_exn "Failure" +and ident_not_found = ident_create_predef_exn "Not_found" +and ident_sys_error = ident_create_predef_exn "Sys_error" +and ident_end_of_file = ident_create_predef_exn "End_of_file" +and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" +and ident_stack_overflow = ident_create_predef_exn "Stack_overflow" +and ident_sys_blocked_io = ident_create_predef_exn "Sys_blocked_io" +and ident_assert_failure = ident_create_predef_exn "Assert_failure" and ident_undefined_recursive_module = - Ident.create_predef_exn "Undefined_recursive_module" + ident_create_predef_exn "Undefined_recursive_module" let path_match_failure = Pident ident_match_failure and path_assert_failure = Pident ident_assert_failure and path_undefined_recursive_module = Pident ident_undefined_recursive_module +let ident_false = ident_create "false" +and ident_true = ident_create "true" +and ident_void = ident_create "()" +and ident_nil = ident_create "[]" +and ident_cons = ident_create "::" +and ident_none = ident_create "None" +and ident_some = ident_create "Some" let build_initial_env add_type add_exception empty_env = let decl_abstr = {type_params = []; @@ -100,7 +117,7 @@ let build_initial_env add_type add_exception empty_env = and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant(["false", [], None; "true", [], None]); + type_kind = Type_variant([ident_false, [], None; ident_true, [], None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -109,7 +126,7 @@ let build_initial_env add_type add_exception empty_env = and decl_unit = {type_params = []; type_arity = 0; - type_kind = Type_variant(["()", [], None]); + type_kind = Type_variant([ident_void, [], None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -139,7 +156,8 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = - Type_variant(["[]", [], None; "::", [tvar; type_list tvar], None]); + Type_variant([ident_nil, [], None; ident_cons, [tvar; type_list tvar], + None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -165,7 +183,7 @@ let build_initial_env add_type add_exception empty_env = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; - type_kind = Type_variant(["None", [], None; "Some", [tvar], None]); + type_kind = Type_variant([ident_none, [], None; ident_some, [tvar], None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -183,7 +201,8 @@ let build_initial_env add_type add_exception empty_env = type_newtype_level = None} in - let add_exception id l = add_exception id { exn_args = l; exn_loc = Location.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 [] ( @@ -232,4 +251,5 @@ let builtin_values = be defined in this file (above!) without breaking .cmi compatibility. *) -let _ = Ident.set_current_time 999 +let _ = Ident.set_current_time 999 +let builtin_idents = List.rev !builtin_idents diff --git a/typing/predef.mli b/typing/predef.mli index bd477ad523..cedcf88915 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -66,3 +66,4 @@ val build_initial_env: (* To initialize linker tables *) val builtin_values: (string * Ident.t) list +val builtin_idents: (string * Ident.t) list diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 1f23448db4..6e7184e892 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -453,7 +453,8 @@ let rec tree_of_typexp sch ty = Otyp_var (false, name_of_type ty) | Tproc _ -> Otyp_proc | Tpackage (p, n, tyl) -> - let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in + 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; @@ -591,8 +592,8 @@ let rec tree_of_type_decl id decl = begin match decl.type_kind with | Type_abstract -> () | Type_variant cstrs -> - List.iter - (fun (_, args,ret_type_opt) -> + List.iter + (fun (_, args,ret_type_opt) -> List.iter mark_loops args; may mark_loops ret_type_opt) cstrs @@ -651,6 +652,7 @@ let rec tree_of_type_decl id decl = (name, args, ty, priv, constraints) and tree_of_constructor (name, args, ret_type_opt) = + let name = Ident.name name in if ret_type_opt = None then (name, tree_of_typlist false args, None) else let nm = !names in names := []; @@ -658,7 +660,7 @@ and tree_of_constructor (name, args, ret_type_opt) = let args = tree_of_typlist false args in names := nm; (name, args, ret) - + and tree_of_constructor_ret = function @@ -666,7 +668,7 @@ and tree_of_constructor_ret = | 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) + (Ident.name name, mut = Mutable, tree_of_typexp false arg) let tree_of_type_declaration id decl rs = Osig_type (tree_of_type_decl id decl, tree_of_rec rs) @@ -723,14 +725,14 @@ let tree_of_metho sch concrete csil (lab, kind, ty) = else csil let rec prepare_class_type params = function - | Tcty_constr (p, tyl, cty) -> + | Cty_constr (p, tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || 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 - | Tcty_signature sign -> + | Cty_signature sign -> let sty = repr sign.cty_self in (* Self may have a name *) let px = proxy sty in @@ -741,13 +743,13 @@ let rec prepare_class_type params = function in 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) -> + | Cty_fun (_, ty, cty) -> mark_loops ty; prepare_class_type params cty let rec tree_of_class_type sch params = function - | Tcty_constr (p', tyl, cty) -> + | Cty_constr (p', tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) @@ -755,7 +757,7 @@ let rec tree_of_class_type sch params = tree_of_class_type sch params cty else Octy_constr (tree_of_path p', tree_of_typlist true tyl) - | Tcty_signature sign -> + | Cty_signature sign -> let sty = repr sign.cty_self in let self_ty = if is_aliased sty then @@ -787,7 +789,7 @@ let rec tree_of_class_type sch params = List.fold_left (tree_of_metho sch sign.cty_concr) csil fields in Octy_signature (self_ty, List.rev csil) - | Tcty_fun (l, ty, cty) -> + | Cty_fun (l, ty, cty) -> let lab = if !print_labels && l <> "" || is_optional l then l else "" in let ty = if is_optional l then @@ -871,33 +873,33 @@ let cltype_declaration id ppf cl = (* Print a module type *) let rec tree_of_modtype = function - | Tmty_ident p -> + | Mty_ident p -> Omty_ident (tree_of_path p) - | Tmty_signature sg -> + | Mty_signature sg -> Omty_signature (tree_of_signature sg) - | Tmty_functor(param, ty_arg, ty_res) -> + | Mty_functor(param, ty_arg, ty_res) -> Omty_functor (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res) and tree_of_signature = function | [] -> [] - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> tree_of_value_description id decl :: tree_of_signature rem - | Tsig_type(id, _, _) :: rem when is_row_name (Ident.name id) -> + | Sig_type(id, _, _) :: rem when is_row_name (Ident.name id) -> tree_of_signature rem - | Tsig_type(id, decl, rs) :: rem -> + | Sig_type(id, decl, rs) :: rem -> Osig_type(tree_of_type_decl id decl, tree_of_rec rs) :: tree_of_signature rem - | Tsig_exception(id, decl) :: rem -> + | Sig_exception(id, decl) :: rem -> tree_of_exception_declaration id decl :: tree_of_signature rem - | Tsig_module(id, mty, rs) :: rem -> + | Sig_module(id, mty, rs) :: rem -> Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) :: tree_of_signature rem - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> tree_of_modtype_declaration id decl :: tree_of_signature rem - | Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem -> + | Sig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem -> tree_of_class_declaration id decl rs :: tree_of_signature rem - | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> tree_of_cltype_declaration id decl rs :: tree_of_signature rem | _ -> assert false @@ -905,8 +907,8 @@ and tree_of_signature = function and tree_of_modtype_declaration id decl = let mty = match decl with - | Tmodtype_abstract -> Omty_abstract - | Tmodtype_manifest mty -> tree_of_modtype mty + | Modtype_abstract -> Omty_abstract + | Modtype_manifest mty -> tree_of_modtype mty in Osig_modtype (Ident.name id, mty) @@ -996,7 +998,7 @@ let rec mismatch unif = function let explanation unif t3 t4 ppf = match t3.desc, t4.desc with - | Tfield _, Tvar _ | Tvar _, Tfield _ -> + | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> fprintf ppf "@,Self type cannot escape its class" | Tconstr (p, tl, _), Tvar _ when unif && t4.level < Path.binding_time p -> diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 5417ebf41f..b546670303 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -38,20 +38,28 @@ val type_scheme_max: ?b_reset_names: bool -> (* Fin Maxence *) val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit -val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item -val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit +val tree_of_exception_declaration: + Ident.t -> exception_declaration -> out_sig_item +val exception_declaration: + Ident.t -> formatter -> exception_declaration -> unit val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit -val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item +val tree_of_modtype_declaration: + Ident.t -> modtype_declaration -> out_sig_item +val tree_of_signature: Types.signature -> out_sig_item list +val tree_of_typexp: bool -> type_expr -> out_type val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit val class_type: formatter -> class_type -> unit -val tree_of_class_declaration: Ident.t -> class_declaration -> rec_status -> out_sig_item +val tree_of_class_declaration: + Ident.t -> class_declaration -> rec_status -> out_sig_item val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit +val tree_of_cltype_declaration: + Ident.t -> class_type_declaration -> rec_status -> out_sig_item +val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit val type_expansion: type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion: type_expr * type_expr -> type_expr * type_expr val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit diff --git a/typing/printtyped.ml b/typing/printtyped.ml new file mode 100644 index 0000000000..7c280ddcb7 --- /dev/null +++ b/typing/printtyped.ml @@ -0,0 +1,794 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Tublic License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: printast.ml 12414 2012-05-02 14:36:55Z lefessan $ *) + +open Asttypes;; +open Format;; +open Lexing;; +open Location;; +open Typedtree;; + +let fmt_position f l = + if l.pos_lnum = -1 + then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) +;; + +let fmt_location f loc = + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; +;; + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; +;; + +let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;; +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; + +let fmt_ident = Ident.print + +let rec fmt_path_aux f x = + match x with + | Path.Pident (s) -> fprintf f "%a" fmt_ident s; + | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s; + | Path.Papply (y, z) -> + fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z; +;; + +let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; +let fmt_path_loc f x = fprintf f "\"%a\"" fmt_path_aux x.txt;; + +let fmt_constant f x = + match x with + | Const_int (i) -> fprintf f "Const_int %d" i; + | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); + | Const_string (s) -> fprintf f "Const_string %S" s; + | Const_float (s) -> fprintf f "Const_float %s" s; + | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; + | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; + | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i; +;; + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable"; + | Mutable -> fprintf f "Mutable"; +;; + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual"; + | Concrete -> fprintf f "Concrete"; +;; + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override"; + | Fresh -> fprintf f "Fresh"; +;; + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec"; + | Recursive -> fprintf f "Rec"; + | Default -> fprintf f "Default"; +;; + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up"; + | Downto -> fprintf f "Down"; +;; + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public"; + | Private -> fprintf f "Private"; +;; + +let line i f s (*...*) = + fprintf f "%s" (String.make (2*i) ' '); + fprintf f s (*...*) +;; + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n"; + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n"; +;; + +let option i f ppf x = + match x with + | None -> line i ppf "None\n"; + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x; +;; + +let longident i ppf li = line i ppf "%a\n" fmt_longident li;; +let path i ppf li = line i ppf "%a\n" fmt_path li;; +let ident i ppf li = line i ppf "%a\n" fmt_ident li;; +let string i ppf s = line i ppf "\"%s\"\n" s;; +let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;; +let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; +let label i ppf x = line i ppf "label=\"%s\"\n" x;; + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ctyp_loc; + let i = i+1 in + match x.ctyp_desc with + | Ttyp_any -> line i ppf "Ptyp_any\n"; + | Ttyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ttyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + string i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ttyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ttyp_constr (li, _, l) -> + line i ppf "Ptyp_constr %a\n" fmt_path li; + list i core_type ppf l; + | Ttyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed); + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ttyp_object (l) -> + line i ppf "Ptyp_object\n"; + list i core_field_type ppf l; + | Ttyp_class (li, _, l, low) -> + line i ppf "Ptyp_class %a\n" fmt_path li; + list i core_type ppf l; + list i string ppf low + | Ttyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ttyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; + core_type i ppf ct; + | Ttyp_package { pack_name = s; pack_fields = l } -> + line i ppf "Ptyp_package %a\n" fmt_path s; + list i package_with ppf l; + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident s; + core_type i ppf t + +and core_field_type i ppf x = + line i ppf "core_field_type %a\n" fmt_location x.field_loc; + let i = i+1 in + match x.field_desc with + | Tcfield (s, ct) -> + line i ppf "Pfield \"%s\"\n" s; + core_type i ppf ct; + | Tcfield_var -> line i ppf "Pfield_var\n"; + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.pat_loc; + let i = i+1 in + match x.pat_extra with + | (Tpat_unpack, _) :: rem -> + line i ppf "Tpat_unpack\n"; + pattern i ppf { x with pat_extra = rem } + | (Tpat_constraint cty, _) :: rem -> + line i ppf "Tpat_constraint\n"; + core_type i ppf cty; + pattern i ppf { x with pat_extra = rem } + | (Tpat_type (id, _), _) :: rem -> + line i ppf "Tpat_type %a\n" fmt_path id; + pattern i ppf { x with pat_extra = rem } + | [] -> + match x.pat_desc with + | Tpat_any -> line i ppf "Ppat_any\n"; + | Tpat_var (s,_) -> line i ppf "Ppat_var \"%a\"\n" fmt_ident s; + | Tpat_alias (p, s,_) -> + line i ppf "Ppat_alias \"%a\"\n" fmt_ident s; + pattern i ppf p; + | Tpat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Tpat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Tpat_construct (li, _, _, po, explicity_arity) -> + line i ppf "Ppat_construct %a\n" fmt_path li; + list i pattern ppf po; + bool i ppf explicity_arity; + | Tpat_variant (l, po, _) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Tpat_record (l, c) -> + line i ppf "Ppat_record\n"; + list i longident_x_pattern ppf l; + | Tpat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Tpat_or (p1, p2, _) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Tpat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + +and expression_extra i ppf x = + match x with + | Texp_constraint (cto1, cto2) -> + line i ppf "Pexp_constraint\n"; + option i core_type ppf cto1; + option i core_type ppf cto2; + | Texp_open (m, _, _) -> + line i ppf "Pexp_open \"%a\"\n" fmt_path m; + | Texp_poly cto -> + line i ppf "Pexp_poly\n"; + option i core_type ppf cto; + | Texp_newtype s -> + line i ppf "Pexp_newtype \"%s\"\n" s; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + let i = + List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1) + (i+1) x.exp_extra + in + match x.exp_desc with + | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li; + | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li; + | Texp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Texp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + expression i ppf e; + | Texp_function (p, l, _partial) -> + line i ppf "Pexp_function \"%s\"\n" p; +(* option i expression ppf eo; *) + list i pattern_x_expression_case ppf l; + | Texp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Texp_match (e, l, partial) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; + | Texp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; + | Texp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Texp_construct (li, _, _, eo, b) -> + line i ppf "Pexp_construct %a\n" fmt_path li; + list i expression ppf eo; + bool i ppf b; + | Texp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Texp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Texp_field (e, li, _, _) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + path i ppf li; + | Texp_setfield (e1, li, _, _, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + path i ppf li; + expression i ppf e2; + | Texp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Texp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Texp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_for (s, _, e1, e2, df, e3) -> + line i ppf "Pexp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Texp_when (e1, e2) -> + line i ppf "Pexp_when\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_send (e, Tmeth_name s, eo) -> + line i ppf "Pexp_send \"%s\"\n" s; + expression i ppf e; + option i expression ppf eo + | Texp_send (e, Tmeth_val s, eo) -> + line i ppf "Pexp_send \"%a\"\n" fmt_ident s; + expression i ppf e; + option i expression ppf eo + | Texp_new (li, _, _) -> line i ppf "Pexp_new %a\n" fmt_path li; + | Texp_setinstvar (_, s, _, e) -> + line i ppf "Pexp_setinstvar \"%a\"\n" fmt_path s; + expression i ppf e; + | Texp_override (_, l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Texp_letmodule (s, _, me, e) -> + line i ppf "Pexp_letmodule \"%a\"\n" fmt_ident s; + module_expr i ppf me; + expression i ppf e; + | Texp_assert (e) -> + line i ppf "Pexp_assert"; + expression i ppf e; + | Texp_assertfalse -> + line i ppf "Pexp_assertfalse"; + | Texp_lazy (e) -> + line i ppf "Pexp_lazy"; + expression i ppf e; + | Texp_object (s, _) -> + line i ppf "Pexp_object"; + class_structure i ppf s + | Texp_pack me -> + line i ppf "Pexp_pack"; + module_expr i ppf me +(*> JOCAML *) + | Texp_asyncsend (e1, e2) -> + line i ppf "Pexp_asyncsend\n"; + expression i ppf e1 ; + expression i ppf e2 + | Texp_spawn e -> + line i ppf "Pexp_spawn\n"; + expression i ppf e + | Texp_par (e1, e2) -> + line i ppf "Pexp_par\n"; + expression i ppf e1 ; + expression i ppf e2 + | Texp_null -> + line i ppf "Pexp_null\n" + | Texp_reply (e, id) -> + line i ppf "Pexp_reply \"%a\"\n" fmt_ident id; + expression i ppf e + | Texp_def (d,e) -> + line i ppf "Pexp_def\n" ; + list i joinautomaton ppf d ; + expression i ppf e + | Texp_loc (_, _) -> assert false +(*< JOCAML *) +and value_description i ppf x = + line i ppf "value_description\n"; + core_type (i+1) ppf x.val_desc; + list (i+1) string ppf x.val_prim; + +and string_option_underscore i ppf = + function + | Some x -> + string i ppf x.txt + | None -> + string i ppf "_" + +and type_declaration i ppf x = + line i ppf "type_declaration %a\n" fmt_location x.typ_loc; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) string_option_underscore ppf x.typ_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.typ_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.typ_manifest; + +and type_kind i ppf x = + match x with + | Ttype_abstract -> + line i ppf "Ptype_abstract\n" + | Ttype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) string_x_core_type_list_x_location ppf l; + | Ttype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; + +and exception_declaration i ppf x = list i core_type ppf x + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.cltyp_loc; + let i = i+1 in + match x.cltyp_desc with + | Tcty_constr (li, _, l) -> + line i ppf "Pcty_constr %a\n" fmt_path li; + list i core_type ppf l; + | Tcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Tcty_fun (l, co, cl) -> + line i ppf "Pcty_fun \"%s\"\n" l; + core_type i ppf co; + class_type i ppf cl; + +and class_signature i ppf { csig_self = ct; csig_fields = l } = + line i ppf "class_signature\n"; + core_type (i+1) ppf ct; + list (i+1) class_type_field ppf l; + +and class_type_field i ppf x = + let loc = x.ctf_loc in + match x.ctf_desc with + | Tctf_inher (ct) -> + line i ppf "Pctf_inher\n"; + class_type i ppf ct; + | Tctf_val (s, mf, vf, ct) -> + line i ppf + "Pctf_val \"%s\" %a %a %a\n" s + fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; + core_type (i+1) ppf ct; + | Tctf_virt (s, pf, ct) -> + line i ppf + "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Tctf_meth (s, pf, ct) -> + line i ppf + "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Tctf_cstr (ct1, ct2) -> + line i ppf "Pctf_cstr %a\n" fmt_location loc; + core_type i ppf ct1; + core_type i ppf ct2; + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.cl_loc; + let i = i+1 in + match x.cl_desc with + | Tcl_ident (li, _, l) -> + line i ppf "Pcl_constr %a\n" fmt_path li; + list i core_type ppf l; + | Tcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Tcl_fun (l, eo, p, e, _) -> assert false (* TODO *) +(* line i ppf "Pcl_fun\n"; + label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; *) + | Tcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Tcl_let (rf, l1, l2, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l1; + list i ident_x_loc_x_expression_def ppf l2; + class_expr i ppf ce; + | Tcl_constraint (ce, Some ct, _, _, _) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + | Tcl_constraint (_, None, _, _, _) -> assert false + (* TODO : is it possible ? see parsetree *) + +and class_structure i ppf { cstr_pat = p; cstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = assert false (* TODO *) +(* let loc = x.cf_loc in + match x.cf_desc with + | Tcf_inher (ovf, ce, so) -> + line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string ppf so; + | Tcf_valvirt (s, mf, ct) -> + line i ppf "Pcf_valvirt \"%s\" %a %a\n" + s.txt fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; + | Tcf_val (s, mf, ovf, e) -> + line i ppf "Pcf_val \"%s\" %a %a %a\n" + s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; + expression (i+1) ppf e; + | Tcf_virt (s, pf, ct) -> + line i ppf "Pcf_virt \"%s\" %a %a\n" + s.txt fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Tcf_meth (s, pf, ovf, e) -> + line i ppf "Pcf_meth \"%s\" %a %a %a\n" + s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; + expression (i+1) ppf e; + | Tcf_constr (ct1, ct2) -> + line i ppf "Pcf_constr %a\n" fmt_location loc; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Tcf_init (e) -> + line i ppf "Pcf_init\n"; + expression (i+1) ppf e; +*) + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.ci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.mty_loc; + let i = i+1 in + match x.mty_desc with + | Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li; + | Tmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Tmty_functor (s, _, mt1, mt2) -> + line i ppf "Pmty_functor \"%a\"\n" fmt_ident s; + module_type i ppf mt1; + module_type i ppf mt2; + | Tmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l; + | Tmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m; + +and signature i ppf x = list i signature_item ppf x.sig_items + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.sig_loc; + let i = i+1 in + match x.sig_desc with + | Tsig_value (s, _, vd) -> + line i ppf "Psig_value \"%a\"\n" fmt_ident s; + value_description i ppf vd; + | Tsig_type (l) -> + line i ppf "Psig_type\n"; + list i string_x_type_declaration ppf l; + | Tsig_exception (s, _, ed) -> + line i ppf "Psig_exception \"%a\"\n" fmt_ident s; + exception_declaration i ppf ed.exn_params; + | Tsig_module (s, _, mt) -> + line i ppf "Psig_module \"%a\"\n" fmt_ident s; + module_type i ppf mt; + | Tsig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i string_x_module_type ppf decls; + | Tsig_modtype (s, _, md) -> + line i ppf "Psig_modtype \"%a\"\n" fmt_ident s; + modtype_declaration i ppf md; + | Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li; + | Tsig_include (mt, _) -> + line i ppf "Psig_include\n"; + module_type i ppf mt; + | Tsig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Tsig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + +and modtype_declaration i ppf x = + match x with + | Tmodtype_abstract -> line i ppf "Pmodtype_abstract\n"; + | Tmodtype_manifest (mt) -> + line i ppf "Pmodtype_manifest\n"; + module_type (i+1) ppf mt; + +and with_constraint i ppf x = + match x with + | Twith_type (td) -> + line i ppf "Pwith_type\n"; + type_declaration (i+1) ppf td; + | Twith_typesubst (td) -> + line i ppf "Pwith_typesubst\n"; + type_declaration (i+1) ppf td; + | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li; + | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li; + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.mod_loc; + let i = i+1 in + match x.mod_desc with + | Tmod_ident (li,_) -> line i ppf "Pmod_ident %a\n" fmt_path li; + | Tmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Tmod_functor (s, _, mt, me) -> + line i ppf "Pmod_functor \"%a\"\n" fmt_ident s; + module_type i ppf mt; + module_expr i ppf me; + | Tmod_apply (me1, me2, _) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> assert false (* TODO *) +(* line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; *) + | Tmod_unpack (e, _) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + +and structure i ppf x = list i structure_item ppf x.str_items + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.str_loc; + let i = i+1 in + match x.str_desc with + | Tstr_eval (e) -> + line i ppf "Pstr_eval\n"; + expression i ppf e; + | Tstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + | Tstr_primitive (s, _, vd) -> + line i ppf "Pstr_primitive \"%a\"\n" fmt_ident s; + value_description i ppf vd; + | Tstr_type l -> + line i ppf "Pstr_type\n"; + list i string_x_type_declaration ppf l; + | Tstr_exception (s, _, ed) -> + line i ppf "Pstr_exception \"%a\"\n" fmt_ident s; + exception_declaration i ppf ed.exn_params; + | Tstr_exn_rebind (s, _, li, _) -> + line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li; + | Tstr_module (s, _, me) -> + line i ppf "Pstr_module \"%a\"\n" fmt_ident s; + module_expr i ppf me; + | Tstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i string_x_modtype_x_module ppf bindings; + | Tstr_modtype (s, _, mt) -> + line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s; + module_type i ppf mt; + | Tstr_open (li, _) -> line i ppf "Pstr_open %a\n" fmt_path li; + | Tstr_class (l) -> + line i ppf "Pstr_class\n"; + list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l); + | Tstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); + | Tstr_include (me, _) -> + line i ppf "Pstr_include"; + module_expr i ppf me +(*> JOCAML *) + | Tstr_def d -> + line i ppf "Pstr_def\n"; + list i joinautomaton ppf d + | Tstr_exn_global (path,_) -> + line i ppf "Pstr_exn_glocal %a\n" fmt_path path + | Tstr_loc _ -> assert false +(*< JOCAML *) + +and string_x_type_declaration i ppf (s, _, td) = + ident i ppf s; + type_declaration (i+1) ppf td; + +and string_x_module_type i ppf (s, _, mty) = + ident i ppf s; + module_type (i+1) ppf mty; + +and string_x_modtype_x_module i ppf (s, _, mty, modl) = + ident i ppf s; + module_type (i+1) ppf mty; + module_expr (i+1) ppf modl; + +and longident_x_with_constraint i ppf (li, _, wc) = + line i ppf "%a\n" fmt_path li; + with_constraint (i+1) ppf wc; + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf "<constraint> %a\n" fmt_location 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, r_opt) = + line i ppf "\"%a\"\n" fmt_ident s; + list (i+1) core_type ppf l; +(* option (i+1) core_type ppf r_opt; *) + +and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) = + line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; + +and string_list_x_location i ppf (l, loc) = + line i ppf "<params> %a\n" fmt_location loc; + list (i+1) string_loc ppf l; + +and longident_x_pattern i ppf (li, _, _, p) = + line i ppf "%a\n" fmt_path li; + pattern (i+1) ppf p; + +and pattern_x_expression_case i ppf (p, e) = + line i ppf "<case>\n"; + pattern (i+1) ppf p; + expression (i+1) ppf e; + +and pattern_x_expression_def i ppf (p, e) = + line i ppf "<def>\n"; + pattern (i+1) ppf p; + expression (i+1) ppf e; + +and string_x_expression i ppf (s, _, e) = + line i ppf "<override> \"%a\"\n" fmt_path s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, _, _, e) = + line i ppf "%a\n" fmt_path li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l, e, _) = + line i ppf "<label> \"%s\"\n" l; + (match e with None -> () | Some e -> expression (i+1) ppf e) + +and ident_x_loc_x_expression_def i ppf (l,_, e) = + line i ppf "<def> \"%a\"\n" fmt_ident l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x with + Ttag (l, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + list (i+1) core_type ppf ctl + | Tinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct +(*> JOCAML *) +and joinautomaton i ppf d = () +(*< JOCAML *) +;; + +let interface ppf x = list 0 signature_item ppf x.sig_items;; + +let implementation ppf x = list 0 structure_item ppf x.str_items;; diff --git a/typing/printtyped.mli b/typing/printtyped.mli new file mode 100644 index 0000000000..7bb594aaae --- /dev/null +++ b/typing/printtyped.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: printast.mli 12404 2012-04-26 13:20:09Z lefessan $ *) + +open Typedtree;; +open Format;; + +val interface : formatter -> signature -> unit;; +val implementation : formatter -> structure -> unit;; diff --git a/typing/stypes.ml b/typing/stypes.ml index 1d2c0efde3..158062f21e 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -157,7 +157,10 @@ let get_info () = let dump filename = if !Clflags.annotations then begin let info = get_info () in - let pp = formatter_of_out_channel (open_out filename) in + let pp = + match filename with + None -> std_formatter + | Some filename -> formatter_of_out_channel (open_out filename) in sort_filter_phrases (); ignore (List.fold_left (print_info pp) Location.none info); phrases := []; diff --git a/typing/stypes.mli b/typing/stypes.mli index 02cccd800d..c51c45e252 100644 --- a/typing/stypes.mli +++ b/typing/stypes.mli @@ -29,7 +29,7 @@ type annotation = val record : annotation -> unit;; val record_phrase : Location.t -> unit;; -val dump : string -> unit;; +val dump : string option -> unit;; val get_location : annotation -> Location.t;; val get_info : unit -> annotation list;; diff --git a/typing/subst.ml b/typing/subst.ml index 4a84a4e285..0a1f18016b 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -49,7 +49,7 @@ let rec modtype_path s = function Pident id as p -> begin try match Tbl.find id s.modtypes with - | Tmty_ident p -> p + | Mty_ident p -> p | _ -> fatal_error "Subst.modtype_path" with Not_found -> p end | Pdot(p, n, pos) -> @@ -110,6 +110,10 @@ let rec typexp s ty = None -> None | Some (p, tl) -> Some (type_path s p, List.map (typexp s) tl))) + | Tfield (m, k, t1, t2) + when s == identity && ty.level < generic_level && m = dummy_method -> + (* not allowed to lower the level of the dummy method *) + Tfield (m, k, t1, typexp s t2) | Tvariant row -> let row = row_repr row in let more = repr row.row_more in @@ -171,7 +175,7 @@ let type_declaration s decl = | Type_variant cstrs -> Type_variant (List.map - (fun (n, args, ret_type) -> + (fun (n, args, ret_type) -> (n, List.map (typexp s) args, may_map (typexp s) ret_type)) cstrs) | Type_record(lbls, rep) -> @@ -180,7 +184,7 @@ let type_declaration s decl = rep) end; type_manifest = - begin + begin match decl.type_manifest with None -> None | Some ty -> Some(typexp s ty) @@ -206,12 +210,12 @@ let class_signature s sign = let rec class_type s = function - Tcty_constr (p, tyl, cty) -> - Tcty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) - | Tcty_signature sign -> - Tcty_signature (class_signature s sign) - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, typexp s ty, class_type s cty) + Cty_constr (p, tyl, cty) -> + Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) + | Cty_signature sign -> + Cty_signature (class_signature s sign) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, typexp s ty, class_type s cty) let class_declaration s decl = let decl = @@ -258,36 +262,36 @@ let exception_declaration s descr = let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) - | Tsig_type(id, d, _) :: sg -> + | Sig_type(id, d, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | Tsig_module(id, mty, _) :: sg -> + | Sig_module(id, mty, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg - | Tsig_modtype(id, d) :: sg -> + | Sig_modtype(id, d) :: sg -> let id' = Ident.rename id in - rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s) + rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) (id' :: idents) sg - | (Tsig_value(id, _) | Tsig_exception(id, _) | - Tsig_class(id, _, _) | Tsig_cltype(id, _, _)) :: sg -> + | (Sig_value(id, _) | Sig_exception(id, _) | + Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> let id' = Ident.rename id in rename_bound_idents s (id' :: idents) sg let rec modtype s = function - Tmty_ident p as mty -> + Mty_ident p as mty -> begin match p with Pident id -> begin try Tbl.find id s.modtypes with Not_found -> mty end | Pdot(p, n, pos) -> - Tmty_ident(Pdot(module_path s p, n, pos)) + Mty_ident(Pdot(module_path s p, n, pos)) | Papply(p1, p2) -> fatal_error "Subst.modtype" end - | Tmty_signature sg -> - Tmty_signature(signature s sg) - | Tmty_functor(id, arg, res) -> + | Mty_signature sg -> + Mty_signature(signature s sg) + | Mty_functor(id, arg, res) -> let id' = Ident.rename id in - Tmty_functor(id', modtype s arg, + Mty_functor(id', modtype s arg, modtype (add_module id (Pident id') s) res) and signature s sg = @@ -300,26 +304,26 @@ and signature s sg = and signature_component s comp newid = match comp with - Tsig_value(id, d) -> - Tsig_value(newid, value_description s d) - | Tsig_type(id, d, rs) -> - Tsig_type(newid, type_declaration s d, rs) - | Tsig_exception(id, d) -> - Tsig_exception(newid, exception_declaration s d) - | Tsig_module(id, mty, rs) -> - Tsig_module(newid, modtype s mty, rs) - | Tsig_modtype(id, d) -> - Tsig_modtype(newid, modtype_declaration s d) - | Tsig_class(id, d, rs) -> - Tsig_class(newid, class_declaration s d, rs) - | Tsig_cltype(id, d, rs) -> - Tsig_cltype(newid, cltype_declaration s d, rs) + Sig_value(id, d) -> + Sig_value(newid, value_description s d) + | Sig_type(id, d, rs) -> + Sig_type(newid, type_declaration s d, rs) + | Sig_exception(id, d) -> + Sig_exception(newid, exception_declaration s d) + | Sig_module(id, mty, rs) -> + Sig_module(newid, modtype s mty, rs) + | Sig_modtype(id, d) -> + Sig_modtype(newid, modtype_declaration s d) + | Sig_class(id, d, rs) -> + Sig_class(newid, class_declaration s d, rs) + | Sig_class_type(id, d, rs) -> + Sig_class_type(newid, cltype_declaration s d, rs) and modtype_declaration s = function - Tmodtype_abstract -> Tmodtype_abstract - | Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty) + Modtype_abstract -> Modtype_abstract + | Modtype_manifest mty -> Modtype_manifest(modtype s mty) -(* For every binding k |-> d of m1, add k |-> f d to m2 +(* For every binding k |-> d of m1, add k |-> f d to m2 and return resulting merged map. *) let merge_tbls f m1 m2 = diff --git a/typing/subst.mli b/typing/subst.mli index cf97788541..b5e2008293 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -48,7 +48,7 @@ val type_declaration: t -> type_declaration -> type_declaration val exception_declaration: t -> exception_declaration -> exception_declaration val class_declaration: t -> class_declaration -> class_declaration -val cltype_declaration: t -> cltype_declaration -> cltype_declaration +val cltype_declaration: t -> class_type_declaration -> class_type_declaration val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 5610c3e94e..cb106c8577 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -17,7 +17,6 @@ open Parsetree open Asttypes open Path open Types -open Typedtree open Typecore open Typetexp open Format @@ -50,6 +49,16 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string +open Typedtree + +let ctyp desc typ env loc = + { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env } +let cltyp desc typ env loc = + { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env } +let mkcf desc loc = { cf_desc = desc; cf_loc = loc } +let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc } + + exception Error of Location.t * error @@ -62,7 +71,7 @@ exception Error of Location.t * error Self type have a dummy private method, thus preventing it to become closed. *) -let dummy_method = Ctype.dummy_method +let dummy_method = Btype.dummy_method (* Path associated to the temporary class type of a class being typed @@ -79,20 +88,20 @@ let unbound_class = Path.Pident (Ident.create "") (* Fully expand the head of a class type *) let rec scrape_class_type = function - Tcty_constr (_, _, cty) -> scrape_class_type cty + Cty_constr (_, _, cty) -> scrape_class_type cty | cty -> cty (* Generalize a class type *) let rec generalize_class_type = function - Tcty_constr (_, params, cty) -> + Cty_constr (_, params, cty) -> List.iter Ctype.generalize params; generalize_class_type cty - | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> + | Cty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> Ctype.generalize sty; Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars; List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> Ctype.generalize ty; generalize_class_type cty @@ -109,20 +118,20 @@ let virtual_methods sign = (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = match cty with - Tcty_constr (_, _, cty) -> + Cty_constr (_, _, cty) -> constructor_type constr cty - | Tcty_signature sign -> + | Cty_signature sign -> constr - | Tcty_fun (l, ty, cty) -> + | Cty_fun (l, ty, cty) -> Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) let rec class_body cty = match cty with - Tcty_constr (_, _, cty') -> + Cty_constr (_, _, cty') -> cty (* Only class bodies can be abbreviated *) - | Tcty_signature sign -> + | Cty_signature sign -> cty - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> class_body cty let rec extract_constraints cty = @@ -140,22 +149,22 @@ let rec extract_constraints cty = let rec abbreviate_class_type path params cty = match cty with - Tcty_constr (_, _, _) | Tcty_signature _ -> - Tcty_constr (path, params, cty) - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, ty, abbreviate_class_type path params cty) + Cty_constr (_, _, _) | Cty_signature _ -> + Cty_constr (path, params, cty) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, ty, abbreviate_class_type path params cty) let rec closed_class_type = function - Tcty_constr (_, params, _) -> + Cty_constr (_, params, _) -> List.for_all Ctype.closed_schema params - | Tcty_signature sign -> + | Cty_signature sign -> Ctype.closed_schema sign.cty_self && Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) sign.cty_vars true - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> Ctype.closed_schema ty && closed_class_type cty @@ -167,22 +176,23 @@ let closed_class cty = let rec limited_generalize rv = function - Tcty_constr (path, params, cty) -> + Cty_constr (path, params, cty) -> List.iter (Ctype.limited_generalize rv) params; limited_generalize rv cty - | Tcty_signature sign -> + | Cty_signature sign -> Ctype.limited_generalize rv sign.cty_self; 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 - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> Ctype.limited_generalize rv ty; limited_generalize rv cty (* Record a class type *) let rc node = - Stypes.record (Stypes.Ti_class node); + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + Stypes.record (Stypes.Ti_class node); (* moved to genannot *) node @@ -194,11 +204,14 @@ let rc node = (* Enter a value in the method environment only *) 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_loc = loc} val_env + Env.enter_value lab {val_type = ty; val_kind = Val_unbound; + Types.val_loc = loc} val_env in (id, val_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) + Env.add_value ?check id {val_type = ty; val_kind = kind; + Types.val_loc = loc} met_env, + Env.add_value id {val_type = ty; val_kind = Val_unbound; + Types.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 = @@ -218,7 +231,8 @@ 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 Location.none 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 @@ -230,7 +244,7 @@ let concr_vals vars = let inheritance self_type env ovf concr_meths warn_vals loc parent = match scrape_class_type parent with - Tcty_signature cl_sig -> + Cty_signature cl_sig -> (* Methods *) begin try @@ -251,7 +265,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = Some Fresh -> let cname = match parent with - Tcty_constr (p, _, _) -> Path.name p + Cty_constr (p, _, _) -> Path.name p | _ -> "inherited" in if not (Concr.is_empty over_meths) then @@ -279,9 +293,13 @@ let virtual_method val_env meths self_type lab priv sty loc = let (_, ty') = Ctype.filter_self_method val_env lab priv meths self_type 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, Field_type_mismatch ("method", lab, trace))) + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify trace -> + raise(Error(loc, Field_type_mismatch ("method", lab, trace))); + end; + cty let delayed_meth_specs = ref [] @@ -294,24 +312,44 @@ let declare_method val_env meths self_type lab priv sty loc = raise(Error(loc, Field_type_mismatch ("method", lab, trace))) in match sty.ptyp_desc, priv with - Ptyp_poly ([],sty), Public -> + Ptyp_poly ([],sty'), Public -> +(* TODO: we moved the [transl_simple_type_univars] outside of the lazy, +so that we can get an immediate value. Is that correct ? Ask Jacques. *) + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in delayed_meth_specs := - lazy (unif (transl_simple_type_univars val_env sty)) :: - !delayed_meth_specs - | _ -> unif (transl_simple_type val_env false sty) + lazy ( + let cty = transl_simple_type_univars val_env sty' in + let ty = cty.ctyp_type in + unif ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: + !delayed_meth_specs; + returned_cty + | _ -> + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + unif ty; + cty let type_constraint val_env sty sty' loc = - let ty = transl_simple_type val_env false sty 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, Unconsistent_constraint trace)) + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + let cty' = transl_simple_type val_env false sty' in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify trace -> + raise(Error(loc, Unconsistent_constraint trace)); + end; + (cty, cty') -let mkpat d = { ppat_desc = d; ppat_loc = Location.none } -let make_method cl_num expr = +let make_method self_loc cl_num expr = + let mkpat d = { ppat_desc = d; ppat_loc = self_loc } in + let mkid s = mkloc s self_loc in { pexp_desc = Pexp_function ("", None, - [mkpat (Ppat_alias (mkpat(Ppat_var "self-*"), - "self-" ^ cl_num)), + [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")), + mkid ("self-" ^ cl_num))), expr]); pexp_loc = expr.pexp_loc } @@ -326,42 +364,56 @@ let add_val env loc lab (mut, virt, ty) val_sig = in Vars.add lab (mut, virt, ty) val_sig -let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = - function +let rec class_type_field env self_type meths + (fields, val_sig, concr_meths, inher) ctf = + let loc = ctf.pctf_loc in + match ctf.pctf_desc with Pctf_inher sparent -> let parent = class_type env sparent in let inher = - match parent with - Tcty_constr (p, tl, _) -> (p, tl) :: inher + match parent.cltyp_type with + Cty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in let (cl_sig, concr_meths, _) = inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc - parent + parent.cltyp_type in let val_sig = Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in - (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; - (val_sig, concr_meths, inher) - - | Pctf_meth (lab, priv, sty, loc) -> - declare_method env meths self_type lab priv sty loc; - (val_sig, Concr.add lab concr_meths, inher) - - | Pctf_cstr (sty, sty', loc) -> - type_constraint env sty sty' loc; - (val_sig, concr_meths, inher) - -and class_signature env sty sign = + (mkctf (Tctf_inher parent) loc :: fields, + val_sig, concr_meths, inher) + + | Pctf_val (lab, mut, virt, sty) -> + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + (mkctf (Tctf_val (lab, mut, virt, cty)) loc :: fields, + add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher) + + | Pctf_virt (lab, priv, sty) -> + let cty = + declare_method env meths self_type lab priv sty ctf.pctf_loc + in + (mkctf (Tctf_virt (lab, priv, cty)) loc :: fields, + val_sig, concr_meths, inher) + + | Pctf_meth (lab, priv, sty) -> + let cty = + declare_method env meths self_type lab priv sty ctf.pctf_loc in + (mkctf (Tctf_meth (lab, priv, cty)) loc :: fields, + val_sig, Concr.add lab concr_meths, inher) + + | Pctf_cstr (sty, sty') -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + (mkctf (Tctf_cstr (cty, cty')) loc :: fields, + val_sig, concr_meths, inher) + +and class_signature env sty sign loc = let meths = ref Meths.empty in - let self_type = Ctype.expand_head env (transl_simple_type env false sty) in + let self_cty = transl_simple_type env false sty in + let self_cty = { self_cty with + ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in + let self_type = self_cty.ctyp_type in (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) @@ -375,45 +427,62 @@ and class_signature env sty sign = end; (* Class type fields *) - let (val_sig, concr_meths, inher) = + let (fields, val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) - (Vars.empty, Concr.empty, []) + ([], Vars.empty, Concr.empty, []) sign in - - {cty_self = self_type; + let cty = {cty_self = self_type; cty_vars = val_sig; cty_concr = concr_meths; cty_inher = inher} + in + { csig_self = self_cty; + csig_fields = fields; + csig_type = cty; + csig_loc = loc; + } and class_type env scty = + let loc = scty.pcty_loc in match scty.pcty_desc with Pcty_constr (lid, styl) -> - let (path, decl) = Typetexp.find_cltype env scty.pcty_loc lid in + let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in if Path.same decl.clty_path unbound_class then - raise(Error(scty.pcty_loc, Unbound_class_type_2 lid)); + raise(Error(scty.pcty_loc, Unbound_class_type_2 lid.txt)); let (params, clty) = Ctype.instance_class decl.clty_params decl.clty_type in if List.length params <> List.length styl then raise(Error(scty.pcty_loc, - Parameter_arity_mismatch (lid, List.length params, + Parameter_arity_mismatch (lid.txt, List.length params, List.length styl))); - List.iter2 + let ctys = List.map2 (fun sty ty -> - let ty' = transl_simple_type env false sty in + let cty' = transl_simple_type env false sty in + let ty' = cty'.ctyp_type in + begin try Ctype.unify env ty' ty with Ctype.Unify trace -> - raise(Error(sty.ptyp_loc, Parameter_mismatch trace))) - styl params; - Tcty_constr (path, params, clty) + raise(Error(sty.ptyp_loc, Parameter_mismatch trace)) + end; + cty' + ) styl params + in + let typ = Cty_constr (path, params, clty) in + cltyp (Tcty_constr ( path, lid , ctys)) typ env loc - | Pcty_signature (sty, sign) -> - Tcty_signature (class_signature env sty sign) + | Pcty_signature pcsig -> + let clsig = class_signature env + pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in + let typ = Cty_signature clsig.csig_type in + cltyp (Tcty_signature clsig) typ env loc | Pcty_fun (l, sty, scty) -> - let ty = transl_simple_type env false sty in - let cty = class_type env scty in - Tcty_fun (l, ty, cty) + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + let clty = class_type env scty in + let typ = Cty_fun (l, ty, clty.cltyp_type) in + cltyp (Tcty_fun (l, cty, clty)) typ env loc let class_type env scty = delayed_meth_specs := []; @@ -424,14 +493,16 @@ let class_type env scty = (*******************************) -let rec class_field cl_num self_type meths vars - (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) = - function +let rec class_field self_loc cl_num self_type meths vars + (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) + cf = + let loc = cf.pcf_loc in + match cf.pcf_desc with Pcf_inher (ovf, sparent, super) -> let parent = class_expr cl_num val_env par_env sparent in let inher = match parent.cl_type with - Tcty_constr (p, tl, _) -> (p, tl) :: inher + Cty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in let (cl_sig, concr_meths, warn_vals) = @@ -469,31 +540,36 @@ let rec class_field cl_num self_type meths vars (val_env, met_env, par_env) in (val_env, met_env, par_env, - lazy(Cf_inher (parent, inh_vars, inh_meths))::fields, + lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc) + :: fields, concr_meths, warn_vals, inher) - | Pcf_valvirt (lab, mut, styp, loc) -> + | Pcf_valvirt (lab, mut, styp) -> if !Clflags.principal then Ctype.begin_def (); - let ty = Typetexp.transl_simple_type val_env false styp in + let cty = Typetexp.transl_simple_type val_env false styp in + let ty = cty.ctyp_type 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 + enter_val cl_num vars false lab.txt 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, + lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty, + met_env' == met_env)) loc) + :: fields, concr_meths, warn_vals, inher) - | Pcf_val (lab, mut, ovf, sexp, loc) -> - if Concr.mem lab warn_vals then begin + | Pcf_val (lab, mut, ovf, sexp) -> + if Concr.mem lab.txt warn_vals then begin if ovf = Fresh then - Location.prerr_warning loc (Warnings.Instance_variable_override[lab]) + Location.prerr_warning lab.loc + (Warnings.Instance_variable_override[lab.txt]) end else begin if ovf = Override then - raise(Error(loc, No_overriding ("instance variable", lab))) + raise(Error(loc, No_overriding ("instance variable", lab.txt))) end; if !Clflags.principal then Ctype.begin_def (); let exp = @@ -503,35 +579,42 @@ let rec class_field cl_num self_type meths vars if !Clflags.principal then begin Ctype.end_def (); Ctype.generalize_structure exp.exp_type - end; + end; let (id, val_env, met_env', par_env) = - enter_val cl_num vars false lab mut Concrete exp.exp_type + enter_val cl_num vars false lab.txt 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, Concr.add lab warn_vals, inher) + lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, + Tcfk_concrete exp, met_env' == met_env)) loc) + :: fields, + concr_meths, Concr.add lab.txt warn_vals, inher) - | Pcf_virt (lab, priv, sty, loc) -> - virtual_method val_env meths self_type lab priv sty loc; - (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) + | Pcf_virt (lab, priv, sty) -> + let cty = virtual_method val_env meths self_type lab.txt priv sty loc in + (val_env, met_env, par_env, + lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc) + ::fields, + concr_meths, warn_vals, inher) - | Pcf_meth (lab, priv, ovf, expr, loc) -> - if Concr.mem lab concr_meths then begin + | Pcf_meth (lab, priv, ovf, expr) -> + if Concr.mem lab.txt concr_meths then begin if ovf = Fresh then - Location.prerr_warning loc (Warnings.Method_override [lab]) + Location.prerr_warning loc (Warnings.Method_override [lab.txt]) end else begin - if ovf = Override then raise(Error(loc, No_overriding("method", lab))) + if ovf = Override then + raise(Error(loc, No_overriding("method", lab.txt))) end; let (_, ty) = - Ctype.filter_self_method val_env lab priv meths self_type + Ctype.filter_self_method val_env lab.txt priv meths self_type in begin try match expr.pexp_desc with Pexp_poly (sbody, sty) -> begin match sty with None -> () - | Some sty -> - Ctype.unify val_env - (Typetexp.transl_simple_type val_env false sty) ty + | Some sty -> + let cty' = Typetexp.transl_simple_type val_env false sty in + let ty' = cty'.ctyp_type in + Ctype.unify val_env ty' ty end; begin match (Ctype.repr ty).desc with Tvar _ -> @@ -546,9 +629,9 @@ let rec class_field cl_num self_type meths vars end | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace))) end; - let meth_expr = make_method cl_num expr in + let meth_expr = make_method self_loc cl_num expr in (* backup variables for Pexp_override *) let vars_local = !vars in @@ -560,17 +643,22 @@ let rec class_field cl_num self_type meths vars vars := vars_local; let texp = type_expect met_env meth_expr meth_type in Ctype.end_def (); - Cf_meth (lab, texp) + mkcf (Tcf_meth (lab.txt, lab, priv, Tcfk_concrete texp, + match ovf with + Override -> true + | Fresh -> false)) loc end in (val_env, met_env, par_env, field::fields, - Concr.add lab concr_meths, warn_vals, inher) + Concr.add lab.txt concr_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_vals, inher) + | Pcf_constr (sty, sty') -> + let (cty, cty') = type_constraint val_env sty sty' loc in + (val_env, met_env, par_env, + lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields, + concr_meths, warn_vals, inher) | Pcf_init expr -> - let expr = make_method cl_num expr in + let expr = make_method self_loc cl_num expr in let vars_local = !vars in let field = lazy begin @@ -582,14 +670,18 @@ let rec class_field cl_num self_type meths vars vars := vars_local; let texp = type_expect met_env expr meth_type in Ctype.end_def (); - Cf_init texp + mkcf (Tcf_init texp) loc end in (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher) -and class_structure cl_num final val_env met_env loc (spat, str) = +and class_structure cl_num final val_env met_env loc + { pcstr_pat = spat; pcstr_fields = str } = (* Environment for substructures *) let par_env = met_env in + (* Location of self. Used for locations of self arguments *) + let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in + (* Self type, with a dummy method preventing it from being closed/escaped. *) let self_type = Ctype.newvar () in Ctype.unify val_env @@ -630,7 +722,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) = (* Typing of class fields *) let (_, _, _, fields, concr_meths, _, inher) = - List.fold_left (class_field cl_num self_type meths vars) + List.fold_left (class_field self_loc cl_num self_type meths vars) (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, []) str in @@ -639,7 +731,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) = {cty_self = public_self; cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; cty_concr = concr_meths; - cty_inher = inher} in + cty_inher = inher} in let methods = get_methods self_type in let priv_meths = List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) @@ -692,18 +784,22 @@ and class_structure cl_num final val_env met_env loc (spat, str) = let added = List.filter (fun x -> List.mem x l1) l2 in if added <> [] then Location.prerr_warning loc (Warnings.Implicit_public_methods added); - {cl_field = fields; cl_meths = meths}, - if final then sign else - {sign with cty_self = Ctype.expand_head val_env public_self} + let sign = if final then sign else + {sign with cty_self = Ctype.expand_head val_env public_self} in + { + cstr_pat = pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths}, sign (* redondant, since already in cstr_type *) and class_expr cl_num val_env met_env scl = match scl.pcl_desc with Pcl_constr (lid, styl) -> - let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid in + let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in if Path.same decl.cty_path unbound_class then - raise(Error(scl.pcl_loc, Unbound_class_2 lid)); + raise(Error(scl.pcl_loc, Unbound_class_2 lid.txt)); let tyl = List.map - (fun sty -> transl_simple_type val_env false sty, sty.ptyp_loc) + (fun sty -> transl_simple_type val_env false sty) styl in let (params, clty) = @@ -712,51 +808,54 @@ and class_expr cl_num val_env met_env scl = let clty' = abbreviate_class_type path params clty in if List.length params <> List.length tyl then raise(Error(scl.pcl_loc, - Parameter_arity_mismatch (lid, List.length params, + Parameter_arity_mismatch (lid.txt, List.length params, List.length tyl))); List.iter2 - (fun (ty',loc) ty -> + (fun cty' ty -> + let ty' = cty'.ctyp_type in try Ctype.unify val_env ty' ty with Ctype.Unify trace -> - raise(Error(loc, Parameter_mismatch trace))) + raise(Error(cty'.ctyp_loc, Parameter_mismatch trace))) tyl params; let cl = - rc {cl_desc = Tclass_ident path; + rc {cl_desc = Tcl_ident (path, lid, tyl); cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env} in let (vals, meths, concrs) = extract_constraints clty in - rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs); + rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs); cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env} | Pcl_structure cl_str -> let (desc, ty) = class_structure cl_num false val_env met_env scl.pcl_loc cl_str in - rc {cl_desc = Tclass_structure desc; + rc {cl_desc = Tcl_structure desc; cl_loc = scl.pcl_loc; - cl_type = Tcty_signature ty; + cl_type = Cty_signature ty; cl_env = val_env} | Pcl_fun (l, Some default, spat, sbody) -> let loc = default.pexp_loc in let scases = - [{ppat_loc = loc; ppat_desc = - Ppat_construct(Longident.(Ldot (Lident"*predef*", "Some")), - Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"}, - false)}, - {pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")}; + [{ppat_loc = loc; ppat_desc = Ppat_construct ( + mknoloc (Longident.(Ldot (Lident"*predef*", "Some"))), + Some{ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*sth*")}, + false)}, + {pexp_loc = loc; pexp_desc = + Pexp_ident(mknoloc (Longident.Lident"*sth*"))}; {ppat_loc = loc; ppat_desc = - Ppat_construct(Longident.(Ldot (Lident"*predef*", "None")), + Ppat_construct(mknoloc (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*")}, + Pexp_ident(mknoloc (Longident.Lident"*opt*"))}, scases)} in let sfun = {pcl_loc = scl.pcl_loc; pcl_desc = - Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, + Pcl_fun(l, None, + {ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*opt*")}, {pcl_loc = scl.pcl_loc; pcl_desc = Pcl_let(Default, [spat, smatch], sbody)})} in @@ -772,30 +871,30 @@ and class_expr cl_num val_env met_env scl = end; let pv = List.map - (function (id, id', ty) -> + begin fun (id, id_loc, 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, - { - exp_desc = Texp_ident(path, vd); - exp_loc = Location.none; + (* do not mark the value as being used *) + let vd = Env.find_value path val_env' in + (id, id_loc, + {exp_desc = + Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); + exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance val_env' vd.val_type; - exp_env = val_env' - }) - ) + exp_env = val_env'}) + end pv in let rec not_function = function - Tcty_fun _ -> false + Cty_fun _ -> false | _ -> true in let partial = Parmatch.check_partial pat.pat_loc [pat, (* Dummy expression *) {exp_desc = Texp_constant (Asttypes.Const_int 1); - exp_loc = Location.none; + exp_loc = Location.none; exp_extra = []; exp_type = Ctype.none; - exp_env = Env.empty }] + exp_env = Env.empty }] in Ctype.raise_nongen_level (); let cl = class_expr cl_num val_env' met_env scl' in @@ -803,16 +902,16 @@ and class_expr cl_num val_env met_env scl = if Btype.is_optional l && not_function cl.cl_type then Location.prerr_warning pat.pat_loc Warnings.Unerasable_optional_argument; - rc {cl_desc = Tclass_fun (pat, pv, cl, partial); + rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial); cl_loc = scl.pcl_loc; - cl_type = Tcty_fun + cl_type = Cty_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 let rec nonopt_labels ls ty_fun = match ty_fun with - | Tcty_fun (l, _, ty_res) -> + | Cty_fun (l, _, ty_res) -> if Btype.is_optional l then nonopt_labels ls ty_res else nonopt_labels (l::ls) ty_res | _ -> ls @@ -830,7 +929,7 @@ and class_expr cl_num val_env met_env scl = in let rec type_args args omitted ty_fun sargs more_sargs = match ty_fun with - | Tcty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] -> + | Cty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] -> let name = Btype.label_name l and optional = if Btype.is_optional l then Optional else Required in @@ -873,7 +972,7 @@ and class_expr cl_num val_env met_env scl = else None in let omitted = if arg = None then (l,ty) :: omitted else omitted in - type_args ((arg,optional)::args) omitted ty_fun sargs more_sargs + type_args ((l,arg,optional)::args) omitted ty_fun sargs more_sargs | _ -> match sargs @ more_sargs with (l, sarg0)::_ -> @@ -884,7 +983,7 @@ and class_expr cl_num val_env met_env scl = | [] -> (List.rev args, List.fold_left - (fun ty_fun (l,ty) -> Tcty_fun(l,ty,ty_fun)) + (fun ty_fun (l,ty) -> Cty_fun(l,ty,ty_fun)) ty_fun omitted) in let (args, cty) = @@ -893,7 +992,7 @@ and class_expr cl_num val_env met_env scl = else type_args [] [] cl.cl_type sargs [] in - rc {cl_desc = Tclass_apply (cl, args); + rc {cl_desc = Tcl_apply (cl, args); cl_loc = scl.pcl_loc; cl_type = cty; cl_env = val_env} @@ -906,14 +1005,15 @@ and class_expr cl_num val_env met_env scl = in let (vals, met_env) = List.fold_right - (fun id (vals, met_env) -> + (fun (id, id_loc) (vals, met_env) -> let path = Pident id in - let vd = Env.find_value path val_env in (* do not mark the value as used *) + (* do not mark the value as used *) + let vd = Env.find_value path val_env in Ctype.begin_def (); let expr = - { - exp_desc = Texp_ident(path, vd); - exp_loc = Location.none; + {exp_desc = + Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); + exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance val_env vd.val_type; exp_env = val_env; } @@ -923,18 +1023,18 @@ and class_expr cl_num val_env met_env scl = let desc = {val_type = expr.exp_type; val_kind = Val_ivar (Immutable, cl_num); - val_loc = vd.val_loc; + Types.val_loc = vd.Types.val_loc; } in let id' = Ident.create (Ident.name id) in - ((id', expr) + ((id', id_loc, expr) :: vals, Env.add_value id' desc met_env)) - (let_bound_idents defs) + (let_bound_idents_with_loc defs) ([], met_env) in let cl = class_expr cl_num val_env met_env scl' in - rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl); + rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env} @@ -950,16 +1050,19 @@ and class_expr cl_num val_env met_env scl = limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type)) cl.cl_type; - limited_generalize (Ctype.row_variable (Ctype.self_type clty)) clty; + limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) + clty.cltyp_type; - begin match Includeclass.class_types val_env cl.cl_type clty with + begin match + Includeclass.class_types val_env cl.cl_type clty.cltyp_type + with [] -> () | error -> raise(Error(cl.cl_loc, Class_match_failure error)) end; - let (vals, meths, concrs) = extract_constraints clty in - rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs); + let (vals, meths, concrs) = extract_constraints clty.cltyp_type in + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); cl_loc = scl.pcl_loc; - cl_type = snd (Ctype.instance_class [] clty); + cl_type = snd (Ctype.instance_class [] clty.cltyp_type); cl_env = val_env} (*******************************) @@ -1025,7 +1128,7 @@ let rec initial_env define_class approx let constr_type = approx cl.pci_expr in if !Clflags.principal then Ctype.generalize_spine constr_type; let dummy_cty = - Tcty_signature + Cty_signature { cty_self = Ctype.newvar (); cty_vars = Vars.empty; cty_concr = Concr.empty; @@ -1072,7 +1175,7 @@ let class_infos define_class kind let params = try let params, loc = cl.pci_params in - List.map (enter_type_variable true loc) params + List.map (fun x -> enter_type_variable true loc x.txt) params with Already_bound -> raise(Error(snd cl.pci_params, Repeated_parameter)) in @@ -1156,7 +1259,7 @@ let class_infos define_class kind (Ctype.instance env constr_type) with Ctype.Unify trace -> raise(Error(cl.pci_loc, - Constructor_type_mismatch (cl.pci_name, trace))) + Constructor_type_mismatch (cl.pci_name.txt, trace))) end; (* Class and class type temporary definitions *) @@ -1287,23 +1390,38 @@ let final_decl env define_class raise(Error(cl.pci_loc, Unbound_type_var(printer, reason))) end; - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, (cl.pci_variance, cl.pci_loc)) + (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coe, expr, + { ci_variance = cl.pci_variance; + ci_loc = cl.pci_loc; + ci_virt = cl.pci_virt; + ci_params = cl.pci_params; +(* TODO : check that we have the correct use of identifiers *) + ci_id_name = cl.pci_name; + ci_id_class = id; + ci_id_class_type = ty_id; + ci_id_object = obj_id; + ci_id_typesharp = cl_id; + ci_expr = expr; + ci_decl = clty; + ci_type_decl = cltydef; + }) +(* (cl.pci_variance, cl.pci_loc)) *) let extract_type_decls - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr, required) decls = (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls let merge_type_decls - (id, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, + (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) = - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr) + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coe, expr, req) let final_env define_class env - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr) = + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coe, expr, req) = (* Add definitions after cleaning them *) Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) ( Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) ( @@ -1314,8 +1432,8 @@ let final_env define_class env (* Check that #c is coercible to c if there is a self-coercion *) let check_coercions env - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coercion_locs, expr) = + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coercion_locs, expr, req) = begin match coercion_locs with [] -> () | loc :: _ -> let cl_ty, obj_ty = @@ -1337,8 +1455,8 @@ let check_coercions env if not (Ctype.opened_object cl_ty) then raise(Error(loc, Cannot_coerce_self obj_ty)) end; - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, expr) + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, req) (*******************************) @@ -1347,8 +1465,8 @@ let type_classes define_class approx kind env cls = List.map (function cl -> (cl, - Ident.create cl.pci_name, Ident.create cl.pci_name, - Ident.create cl.pci_name, Ident.create ("#" ^ cl.pci_name))) + Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, + Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt))) cls in Ctype.init_def (Ident.current_time ()); @@ -1376,7 +1494,7 @@ let class_declaration env sexpr = let class_description env sexpr = let expr = class_type env sexpr in - (expr, expr) + (expr, expr.cltyp_type) let class_declarations env cls = type_classes true approx_declaration class_declaration env cls @@ -1390,14 +1508,15 @@ let class_type_declarations env cls = in (List.map (function - (_, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) -> - (ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr)) + (_, id_loc, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + _, _, ci) -> + (ty_id, id_loc, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci)) decl, env) let rec unify_parents env ty cl = match cl.cl_desc with - Tclass_ident p -> + Tcl_ident (p, _, _) -> begin try let decl = Env.find_class p env in let _, body = Ctype.find_cltype_for_path env decl.cty_path in @@ -1406,16 +1525,16 @@ let rec unify_parents env ty cl = Not_found -> () | exn -> assert false end - | Tclass_structure st -> unify_parents_struct env ty st - | Tclass_fun (_, _, cl, _) - | Tclass_apply (cl, _) - | Tclass_let (_, _, _, cl) - | Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl + | Tcl_structure st -> unify_parents_struct env ty st + | Tcl_fun (_, _, _, cl, _) + | Tcl_apply (cl, _) + | Tcl_let (_, _, _, cl) + | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl and unify_parents_struct env ty st = List.iter - (function Cf_inher (cl, _, _) -> unify_parents env ty cl + (function {cf_desc = Tcf_inher (_, cl, _, _, _)} -> unify_parents env ty cl | _ -> ()) - st.cl_field + st.cstr_fields let type_object env loc s = incr class_num; @@ -1438,7 +1557,8 @@ let approx_class sdecl = let self' = { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in let clty' = - { pcty_desc = Pcty_signature(self', []); + { pcty_desc = Pcty_signature { pcsig_self = self'; + pcsig_fields = []; pcsig_loc = Location.none }; pcty_loc = sdecl.pci_expr.pcty_loc } in { sdecl with pci_expr = clty' } @@ -1602,4 +1722,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 9841ed4010..3329a8206f 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -14,39 +14,70 @@ open Asttypes open Types -open Typedtree open Format val class_declarations: Env.t -> Parsetree.class_declaration list -> - (Ident.t * class_declaration * - Ident.t * cltype_declaration * + (Ident.t * string loc * class_declaration * + Ident.t * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * - int * string list * class_expr) list * Env.t + int * string list * Typedtree.class_declaration) list * Env.t + +(* +and class_declaration = + (class_expr, Types.class_declaration) class_infos +*) val class_descriptions: Env.t -> Parsetree.class_description list -> - (Ident.t * class_declaration * - Ident.t * cltype_declaration * + (Ident.t * string loc * class_declaration * + Ident.t * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * - int * string list * class_type) list * Env.t + int * string list * Typedtree.class_description) list * Env.t + +(* +and class_description = + (class_type, unit) class_infos +*) val class_type_declarations: Env.t -> Parsetree.class_description list -> - (Ident.t * cltype_declaration * + (Ident.t * string loc * class_type_declaration * + Ident.t * type_declaration * Ident.t * type_declaration * - Ident.t * type_declaration) list * Env.t + Typedtree.class_type_declaration) list * Env.t + +(* +and class_type_declaration = + (class_type, Types.class_type_declaration) class_infos +*) val approx_class_declarations: Env.t -> Parsetree.class_description list -> - (Ident.t * cltype_declaration * + (Ident.t * string loc * class_type_declaration * + Ident.t * type_declaration * Ident.t * type_declaration * - Ident.t * type_declaration) list + Typedtree.class_type_declaration) list val virtual_methods: Types.class_signature -> label list +(* +val type_classes : + bool -> + ('a -> Types.type_expr) -> + (Env.t -> 'a -> 'b * Types.class_type) -> + Env.t -> + 'a Parsetree.class_infos list -> + ( Ident.t * Types.class_declaration * + Ident.t * Types.class_type_declaration * + Ident.t * Types.type_declaration * + Ident.t * Types.type_declaration * + int * string list * 'b * 'b Typedtree.class_infos) + list * Env.t +*) + type error = Unconsistent_constraint of (type_expr * type_expr) list | Field_type_mismatch of string * string * (type_expr * type_expr) list diff --git a/typing/typecore.ml b/typing/typecore.ml index 0ca812b984..957eb01df6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -33,7 +33,7 @@ type error = | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr | Label_multiply_defined of Longident.t - | Label_missing of string list + | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Incomplete_format of string | Bad_conversion of string * int * char @@ -96,7 +96,7 @@ let type_package = let type_object = ref (fun env s -> assert false : Env.t -> Location.t -> Parsetree.class_structure -> - class_structure * class_signature * string list) + Typedtree.class_structure * Types.class_signature * string list) (* Saving and outputting type information. @@ -105,14 +105,20 @@ let type_object = or [Typedtree.pattern] that will end up in the typed AST. *) let re node = + Cmt_format.add_saved_type (Cmt_format.Partial_expression node); Stypes.record (Stypes.Ti_expr node); node ;; let rp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); Stypes.record (Stypes.Ti_pat node); node ;; + +let snd3 (_,x,_) = x +let thd4 (_,_, x,_) = x + (* Upper approximation of free identifiers on the parse tree *) let iter_expression f e = @@ -153,7 +159,7 @@ let iter_expression f e = | 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_object { pcstr_fields = fs } -> List.iter class_field fs | Pexp_pack me -> module_expr me (*>JOCAML *) | Pexp_spawn e -> expr e @@ -204,7 +210,7 @@ let iter_expression f e = and class_expr ce = match ce.pcl_desc with | Pcl_constr _ -> () - | Pcl_structure (_, cfl) -> List.iter class_field cfl + | Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs | Pcl_fun (_, eo, _, ce) -> may expr eo; class_expr ce | Pcl_apply (ce, lel) -> class_expr ce; List.iter (fun (_, e) -> expr e) lel @@ -212,10 +218,11 @@ let iter_expression f e = List.iter (fun (_, e) -> expr e) pel; class_expr ce | Pcl_constraint (ce, _) -> class_expr ce - and class_field = function + and class_field cf = + match cf.pcf_desc with | Pcf_inher (_, ce, _) -> class_expr ce - | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () - | Pcf_val (_,_,_, e, _) | Pcf_meth (_,_,_, e, _) -> expr e + | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> () + | Pcf_val (_,_,_,e) | Pcf_meth (_,_,_,e) -> expr e | Pcf_init e -> expr e in @@ -225,7 +232,7 @@ let iter_expression f e = let all_idents el = let idents = Hashtbl.create 8 in let f = function - | {pexp_desc=Pexp_ident (Longident.Lident id); _} -> + | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} -> Hashtbl.replace idents id () | _ -> () in @@ -249,15 +256,20 @@ let type_constant = function let type_option ty = newty (Tconstr(Predef.path_option,[ty], ref Mnil)) +let mkexp exp_desc exp_type exp_loc exp_env = + { exp_desc; exp_type; exp_loc; exp_env; exp_extra = [] } + let option_none ty loc = - let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in - { exp_desc = Texp_construct(cnone, []); - exp_type = ty; exp_loc = loc; exp_env = Env.initial } + let lid = Longident.Lident "None" in + let (path, cnone) = Env.lookup_constructor lid Env.initial in + mkexp (Texp_construct( path, mknoloc lid, cnone, [], false)) + ty loc Env.initial let option_some texp = - let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in - { exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc; - exp_type = type_option texp.exp_type; exp_env = texp.exp_env } + let lid = Longident.Lident "Some" in + let (path, csome) = Env.lookup_constructor lid Env.initial in + mkexp ( Texp_construct(path, mknoloc lid , csome, [texp],false) ) + (type_option texp.exp_type) texp.exp_loc texp.exp_env let extract_option_type env ty = match expand_head env ty with {desc = Tconstr(path, [ty], _)} @@ -328,6 +340,7 @@ let unify_pat_types_gadt loc env ty ty' = (* 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 @@ -349,7 +362,7 @@ let finalize_variant pat = 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 -> + | Reither (c, l, true, e) when not (row_fixed row) -> set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; @@ -373,11 +386,12 @@ let has_variants p = (* pattern environment *) -let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t * bool (* as-variable *)) list) +let pattern_variables = ref ([] : + (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list) let pattern_force = ref ([] : (unit -> unit) list) let pattern_scope = ref (None : Annot.ident option);; let allow_modules = ref false -let module_variables = ref ([] : (string * Location.t) list) +let module_variables = ref ([] : (string loc * Location.t) list) let reset_pattern scope allow = pattern_variables := []; pattern_force := []; @@ -387,24 +401,26 @@ let reset_pattern scope allow = ;; let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty = - if List.exists (fun (id, _, _, _) -> Ident.name id = name) !pattern_variables - then raise(Error(loc, Multiply_bound_variable name)); - let id = Ident.create name in - pattern_variables := (id, ty, loc, is_as_variable) :: !pattern_variables; + if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) + !pattern_variables + then raise(Error(loc, Multiply_bound_variable name.txt)); + let id = Ident.create name.txt in + pattern_variables := + (id, ty, name, loc, is_as_variable) :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (Error (loc, Modules_not_allowed)); 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; + end else + (* moved to genannot *) + may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) + !pattern_scope; 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 = @@ -414,7 +430,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,a1)::rem1, (x2,t2,l2,a2)::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 @@ -427,9 +443,9 @@ let enter_orpat_variables loc env p1_vs p2_vs = (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 @@ -438,11 +454,11 @@ let enter_orpat_variables loc env p1_vs p2_vs = let rec build_as_type env p = match p.pat_desc with - Tpat_alias(p1, _) -> build_as_type env p1 + Tpat_alias(p1,_, _) -> build_as_type env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl) - | Tpat_construct(cstr, pl) -> + | Tpat_construct(_, _, cstr, pl,_) -> let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in if keep then p.pat_type else let tyl = List.map (build_as_type env) pl in @@ -455,11 +471,11 @@ let rec build_as_type env p = newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); row_bound=(); row_name=None; row_fixed=false; row_closed=false}) - | Tpat_record lpl -> - let lbl = fst(List.hd lpl) in + | Tpat_record (lpl,_) -> + let lbl = thd4 (List.hd lpl) in if lbl.lbl_private = Private then p.pat_type else let ty = newvar () in - let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in + let ppl = List.map (fun (_, _, l, p) -> l.lbl_pos, p) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; @@ -508,7 +524,7 @@ let build_or_pat env loc lid = (l, Reither(true,[], true, ref None)) :: fields | Rpresent (Some ty) -> (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; - pat_type=ty}) + pat_type=ty; pat_extra=[];}) :: pats, (l, Reither(false, [ty], true, ref None)) :: fields | _ -> pats, fields) @@ -522,7 +538,7 @@ let build_or_pat env loc lid = let row' = ref {row with row_more=newvar()} in let pats = List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; - pat_env=env; pat_type=ty}) + pat_env=env; pat_type=ty; pat_extra=[];}) pats in match pats with @@ -530,38 +546,41 @@ let build_or_pat env loc lid = | pat :: pats -> let r = List.fold_left - (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); + (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; pat_loc=gloc; pat_env=env; pat_type=ty}) pat pats in - (rp { r with pat_loc = loc },ty) + (path, rp { r with pat_loc = loc },ty) (* Records *) let rec find_record_qual = function | [] -> None - | (Longident.Ldot (modname, _), _) :: _ -> Some modname + | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname | _ :: rest -> find_record_qual rest -let type_label_a_list ?labels env loc type_lbl_a lid_a_list = +let type_label_a_list ?labels env 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 + let path, label = + match lid.txt, labels, record_qual with + Longident.Lident s, Some labels, _ when Hashtbl.mem labels s -> + (Hashtbl.find labels s : Path.t * Types.label_description) + | Longident.Lident s, _, Some modname -> + Typetexp.find_label env lid.loc (Longident.Ldot (modname, s)) + | _ -> + Typetexp.find_label env lid.loc lid.txt + in (path, lid, label, a) + ) lid_a_list in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = List.sort - (fun (lbl1,_) (lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + (fun ( _, _, lbl1,_) ( _,_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in List.map type_lbl_a lbl_a_list +;; let lid_of_label label = match repr label.lbl_res with @@ -575,10 +594,10 @@ let lid_of_label label = let check_recordpat_labels loc lbl_pat_list closed = match lbl_pat_list with | [] -> () (* should not happen *) - | (label1, _) :: _ -> + | (_, _, label1, _) :: _ -> let all = label1.lbl_all in let defined = Array.make (Array.length all) false in - let check_defined (label, _) = + let check_defined (_, _, label, _) = if defined.(label.lbl_pos) then raise(Error(loc, Label_multiply_defined (Longident.Lident label.lbl_name))) @@ -626,28 +645,30 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = Ppat_any -> rp { pat_desc = Tpat_any; - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_var name -> let id = enter_variable loc name expected_ty in rp { - pat_desc = Tpat_var id; - pat_loc = loc; + pat_desc = Tpat_var (id, name); + pat_loc = loc; pat_extra=[]; 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_desc = Tpat_var (id, name); + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, loc]; pat_type = expected_ty; pat_env = !env } - | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc}, + | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc}, ({ptyp_desc=Ptyp_poly _} as sty)) -> (* explicitly polymorphic type *) - let ty, force = Typetexp.transl_simple_type_delayed !env sty in - unify_pat_types loc !env ty expected_ty; + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in + unify_pat_types lloc !env ty expected_ty; pattern_force := force :: !pattern_force; begin match ty.desc with | Tpoly (body, tyl) -> @@ -655,11 +676,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = 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 } + let id = enter_variable lloc name ty' in + rp { + pat_desc = Tpat_var (id, name); + pat_loc = lloc; + pat_extra = [Tpat_constraint cty, loc]; + pat_type = ty; + pat_env = !env + } | _ -> assert false end | Ppat_alias(sq, name) -> @@ -670,15 +694,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = generalize ty_var; let id = enter_variable ~is_as_variable:true loc name ty_var in rp { - pat_desc = Tpat_alias(q, id); - pat_loc = loc; + pat_desc = Tpat_alias(q, id, name); + pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; 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_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_tuple spl -> @@ -688,16 +712,17 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp 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_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_construct(lid, sarg, explicit_arity) -> - let constr = - match lid, constrs with + let (constr_path, constr) = + match lid.txt, constrs with Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> Hashtbl.find constrs s - | _ -> Typetexp.find_constructor !env loc lid + | _ -> Typetexp.find_constructor !env loc lid.txt in + Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) 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 @@ -716,7 +741,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then - raise(Error(loc, Constructor_arity_mismatch(lid, + raise(Error(loc, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); let (ty_args, ty_res) = instance_constructor ~in_pattern:(env, get_newtype_level ()) constr @@ -727,8 +752,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types loc !env ty_res expected_ty; let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in rp { - pat_desc = Tpat_construct(constr, args); - pat_loc = loc; + pat_desc=Tpat_construct(constr_path, lid, constr, args,explicit_arity); + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_variant(l, sarg) -> @@ -744,11 +769,11 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = 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_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_record(lid_sp_list, closed) -> - let type_label_pat (label, sarg) = + let type_label_pat (label_path, label_lid, label, sarg) = begin_def (); let (vars, ty_arg, ty_res) = instance_label false label in if vars = [] then end_def (); @@ -768,14 +793,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = if List.exists instantiated vars then raise (Error(loc, Polymorphic_label (lid_of_label label))) end; - (label, arg) + (label_path, label_lid, label, arg) in let lbl_pat_list = - type_label_a_list ?labels !env loc type_label_pat lid_sp_list in + type_label_a_list ?labels !env 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_desc = Tpat_record (lbl_pat_list, closed); + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_array spl -> @@ -786,7 +811,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = 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_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_or(sp1, sp2) -> @@ -801,23 +826,25 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pattern_variables := p1_variables; rp { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None); - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_lazy sp1 -> let nv = newvar () in - unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) expected_ty; + 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_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_constraint(sp, sty) -> (* 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 cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in let ty, expected_ty' = if separate then begin end_def(); @@ -833,15 +860,18 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pattern_force := force :: !pattern_force; if separate then match p.pat_desc with - Tpat_var id -> + Tpat_var (id,s) -> {p with pat_type = ty; - pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id)} - | _ -> {p with pat_type = ty} + pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s); + pat_extra = [Tpat_constraint cty, loc]; + } + | _ -> {p with pat_type = ty; + pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra} else p | Ppat_type lid -> - let (r,ty) = build_or_pat !env loc lid in + let (path, p,ty) = build_or_pat !env loc lid.txt in unify_pat_types loc !env ty expected_ty; - r + { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra } let type_pat ?(allow_existentials=false) ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty = @@ -888,10 +918,10 @@ let rec iter3 f lst1 lst2 lst3 = let add_pattern_variables ?check ?check_as env = let pv = get_ref pattern_variables in (List.fold_right - (fun (id, ty, loc, as_var) env -> + (fun (id, ty, name, loc, as_var) env -> let check = if as_var then check_as else check in let e1 = Env.add_value ?check id - {val_type = ty; val_kind = Val_reg; val_loc = loc} env in + {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env in Env.add_annot id (Annot.Iref_internal loc) e1) pv env, get_ref module_variables) @@ -925,15 +955,15 @@ 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, as_var) (pv, env) -> + (fun (id, ty, name, 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, + ((id', name, id, ty)::pv, Env.add_value id' {val_type = ty; val_kind = Val_ivar (Immutable, cl_num); - val_loc = loc; + Types.val_loc = loc; } ~check env)) !pattern_variables ([], met_env) @@ -945,8 +975,8 @@ let mkpat d = { ppat_desc = d; ppat_loc = Location.none } let type_self_pattern cl_num privty val_env met_env par_env spat = let spat = - mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")), - "selfpat-" ^ cl_num)) + mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")), + mknoloc ("selfpat-" ^ cl_num))) in reset_pattern None false; let nv = newvar() in @@ -958,20 +988,20 @@ 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, as_var) (val_env, met_env, par_env) -> + (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) -> (Env.add_value id {val_type = ty; val_kind = Val_unbound; - val_loc = loc; + Types.val_loc = loc; } val_env, Env.add_value id {val_type = ty; val_kind = Val_self (meths, vars, cl_num, privty); - val_loc = loc; + Types.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; - val_loc = loc; + Types.val_loc = loc; } par_env)) pv (val_env, met_env, par_env) in @@ -987,6 +1017,9 @@ let force_delayed_checks () = reset_delayed_checks (); Btype.backtrack snap +let fst3 (x, _, _) = x +let snd3 (_, x, _) = x + (*> JOCAML *) (**************************) (* Collecting port names *) @@ -1016,21 +1049,20 @@ let reset_reaction scp = (* get or create channel identifier *) let create_channel chan = - let name = chan.pjident_desc in + let name = chan.txt in let rec do_rec = function | [] -> (* add a new channel *) (* Channels must differ from other ids in set of join definitions *) let p id = Ident.name id = name in if List.exists p !def_ids then - raise (Error (chan.pjident_loc, Multiply_bound_variable name)) ; - let id = Ident.create chan.pjident_desc + raise (Error (chan.loc, Multiply_bound_variable name)) ; + let id = Ident.create name and ty = newvar() - and loc = chan.pjident_loc + and loc = chan.loc and ty_arg = newvar() in def_ids := id :: !def_ids ; auto_chans := (id, ty, loc, ty_arg) :: !auto_chans ; begin - let name = chan.pjident_desc in match !def_scope with | None -> () | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); @@ -1045,10 +1077,10 @@ let create_channel chan = let enter_channel chan = (* Channels must differ from other channels in reaction rule *) - let name = chan.pjident_desc in + let name = chan.txt in let p id = id = name in if List.exists p !reaction_chans then - raise (Error (chan.pjident_loc, Multiply_bound_variable name)) ; + raise (Error (chan.loc, Multiply_bound_variable name)) ; reaction_chans := name :: !reaction_chans ; create_channel chan @@ -1079,7 +1111,7 @@ let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (fun sjpat -> let schan, sarg = sjpat.pjpat_desc in let (id, ty, ty_arg) = enter_channel schan in - let chan = mk_jident id schan.pjident_loc ty tenv + let chan = mk_jident id schan.loc ty tenv and arg = let rtenv = ref tenv and ty_pat = newvar () in @@ -1170,45 +1202,51 @@ let type_autos_lhs env autos scope = let rec is_nonexpansive exp = match exp.exp_desc with - Texp_ident(_,_) -> true + Texp_ident(_,_,_) -> true | Texp_constant _ -> true | Texp_let(rec_flag, pat_exp_list, body) -> List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list && is_nonexpansive body | Texp_function _ -> true - | Texp_apply(e, (None,_)::el) -> - is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map fst el) + | Texp_apply(e, (_,None,_)::el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el) | Texp_tuple el -> List.for_all is_nonexpansive el - | Texp_construct(_, el) -> + | Texp_construct(_, _, _, el,_) -> List.for_all is_nonexpansive el | Texp_variant(_, arg) -> is_nonexpansive_opt arg | Texp_record(lbl_exp_list, opt_init_exp) -> List.for_all - (fun (lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp) + (fun (_, _, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp) lbl_exp_list && is_nonexpansive_opt opt_init_exp - | Texp_field(exp, lbl) -> is_nonexpansive exp + | Texp_field(exp, _, lbl, _) -> is_nonexpansive exp | Texp_array [] -> true | Texp_ifthenelse(cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *) - | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> + | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> true (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e - | Texp_object ({cl_field=fields}, {cty_vars=vars}, _) -> + | Texp_object ({cstr_fields=fields; cstr_type = { cty_vars=vars}}, _) -> let count = ref 0 in List.for_all - (function - Cf_meth _ -> true - | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e - | Cf_init e -> is_nonexpansive e - | Cf_inher _ -> false) + (fun field -> match field.cf_desc with + Tcf_meth _ -> true + | Tcf_val (_,_, _, _, Tcfk_concrete e,_) -> + incr count; is_nonexpansive e + | Tcf_val (_,_, _, _, Tcfk_virtual _,_) -> + incr count; true + | Tcf_init e -> is_nonexpansive e + | Tcf_constr _ -> true + | Tcf_inher _ -> false) fields && Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 + | Texp_letmodule (_, _, mexp, e) -> + is_nonexpansive_mod mexp && is_nonexpansive e | Texp_pack mexp -> is_nonexpansive_mod mexp | _ -> false @@ -1218,17 +1256,18 @@ and is_nonexpansive_mod mexp = | Tmod_ident _ -> true | Tmod_functor _ -> true | Tmod_unpack (e, _) -> is_nonexpansive e - | Tmod_constraint (m, _, _) -> is_nonexpansive_mod m - | Tmod_structure items -> + | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m + | Tmod_structure str -> List.for_all - (function + (fun item -> match item.str_desc with | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ - | Tstr_open _ | Tstr_cltype _ | Tstr_exn_rebind _ -> true + | Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true | Tstr_value (_, pat_exp_list) -> List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list - | Tstr_module (_, m) | Tstr_include (m, _) -> is_nonexpansive_mod m + | Tstr_module (_, _, m) | Tstr_include (m, _) -> is_nonexpansive_mod m | Tstr_recmodule id_mod_list -> - List.for_all (fun (_, m) -> is_nonexpansive_mod m) id_mod_list + List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m) + id_mod_list | Tstr_exception _ -> false (* true would be unsound *) | Tstr_class _ -> false (* could be more precise *) (*>JOCAML*) @@ -1236,7 +1275,7 @@ and is_nonexpansive_mod mexp = | Tstr_exn_global (_, _)|Tstr_loc _|Tstr_def _ -> false (*<JOCAML*) ) - items + str.str_items | Tmod_apply _ -> false and is_nonexpansive_opt = function @@ -1459,7 +1498,7 @@ let rec approx_type env sty = newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> begin try - let (path, decl) = Env.lookup_type lid env in + let (path, decl) = Env.lookup_type lid.txt env in if List.length ctl <> decl.type_arity then raise Not_found; let tyl = List.map (approx_type env) ctl in newconstr path tyl @@ -1560,26 +1599,30 @@ let self_coercion = ref ([] : (Path.t * Location.t list ref) list) (* Helpers for packaged modules. *) 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))) + let fields = List.map (fun (name, ct) -> + name, Typetexp.transl_simple_type env false ct) l in + let ty = newty (Tpackage (s, + List.map fst l, + List.map (fun (_, cty) -> cty.ctyp_type) fields)) + in + (s, fields, ty) -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}}, + 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(mkloc (Longident.Lident name.txt) name.loc); + pexp_loc=name.loc}}, sexp)}) sexp unpacks (* Helpers for type_cases *) -let iter_ppat f p = +let iter_ppat f p = match p.ppat_desc with - | Ppat_any | Ppat_var _ | Ppat_constant _ - | Ppat_type _ | Ppat_unpack _ -> () + | 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 @@ -1600,7 +1643,8 @@ let contains_gadt env p = match p.ppat_desc with Ppat_construct (lid, _, _) -> begin try - if (Env.lookup_constructor lid env).cstr_generalized then raise Exit + let (_path, cstr) = Env.lookup_constructor lid.txt env in + if cstr.cstr_generalized then raise Exit with Not_found -> () end; iter_ppat loop p | _ -> iter_ppat loop p @@ -1687,6 +1731,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = + Cmt_format.add_saved_type (Cmt_format.Partial_expression exp); Stypes.record (Stypes.Ti_expr exp); unify_exp env exp (instance env ty_expected); exp @@ -1696,13 +1741,13 @@ and do_type_expect ?in_function ctx env sexp ty_expected = check_expression ctx sexp ; begin if !Clflags.annotations then begin - try let (path, annot) = Env.lookup_annot lid env in + try let (path, annot) = Env.lookup_annot lid.txt env in Stypes.record (Stypes.An_ident ( loc, Path.name ~paren:Oprint.parenthesized_ident path, annot)) with _ -> () end; - let (path, desc) = Typetexp.find_value env loc lid in + let (path, desc) = Typetexp.find_value env loc lid.txt in rue { exp_desc = begin match desc.val_kind with @@ -1710,45 +1755,48 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let (self_path, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in - Texp_instvar(self_path, path) + Texp_instvar(self_path, path, + match lid.txt with + Longident.Lident txt -> { txt; loc = lid.loc } + | _ -> assert false) | Val_self (_, _, cl_num, _) -> let (path, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in - Texp_ident(path, desc) + Texp_ident(path, lid, desc) | Val_unbound -> - raise(Error(loc, Masked_instance_variable lid)) + raise(Error(loc, Masked_instance_variable lid.txt)) | _ -> - Texp_ident(path, desc) + Texp_ident(path, lid, desc) end; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env desc.val_type; exp_env = env } end | Pexp_constant(Const_int 0) when ctx=P -> rue { - exp_desc = Texp_null; - exp_loc = sexp.pexp_loc; - exp_type = Predef.type_process []; - exp_env = env; } + exp_desc = Texp_null; + exp_loc = sexp.pexp_loc; exp_extra = []; + exp_type = Predef.type_process []; + exp_env = env; } | Pexp_constant(Const_string s as cst) -> check_expression ctx sexp ; 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 } + exp_desc = Texp_constant cst; + exp_loc = loc; exp_extra = []; + exp_type = + (* Terrible hack for format strings *) + begin match (repr (expand_head env ty_expected)).desc with + Tconstr(path, _, _) when Path.same path Predef.path_format6 -> + type_format loc s + | _ -> instance_def Predef.type_string + end; + exp_env = env } | Pexp_constant cst -> check_expression ctx sexp ; rue { exp_desc = Texp_constant cst; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = type_constant cst; exp_env = env } | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat -> @@ -1767,10 +1815,10 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let body = do_type_expect ctx 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 } + exp_desc = Texp_let(rec_flag, pat_exp_list, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_env = env } | Pexp_function (l, Some default, [spat, sbody]) -> check_expression ctx sexp ; let default_loc = default.pexp_loc in @@ -1778,14 +1826,16 @@ and do_type_expect ?in_function ctx env sexp ty_expected = {ppat_loc = default_loc; ppat_desc = Ppat_construct - (Longident.(Ldot (Lident "*predef*", "Some")), - Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"}, + (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))), + Some {ppat_loc = default_loc; + ppat_desc = Ppat_var (mknoloc "*sth*")}, false)}, {pexp_loc = default_loc; - pexp_desc = Pexp_ident(Longident.Lident "*sth*")}; + pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))}; {ppat_loc = default_loc; ppat_desc = Ppat_construct - (Longident.(Ldot (Lident "*predef*", "None")), None, false)}, + (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))), + None, false)}, default; ] in let smatch = { @@ -1793,7 +1843,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = pexp_desc = Pexp_match ({ pexp_loc = loc; - pexp_desc = Pexp_ident(Longident.Lident "*opt*") + pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*opt*")) }, scases ) @@ -1804,7 +1854,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Pexp_function ( l, None, [ {ppat_loc = loc; - ppat_desc = Ppat_var "*opt*"}, + ppat_desc = Ppat_var (mknoloc "*opt*")}, {pexp_loc = loc; pexp_desc = Pexp_let(Default, [spat, smatch], sbody); } @@ -1856,8 +1906,8 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Location.prerr_warning (fst (List.hd cases)).pat_loc Warnings.Unerasable_optional_argument; re { - exp_desc = Texp_function(cases, partial); - exp_loc = loc; + exp_desc = Texp_function(l,cases, partial); + exp_loc = loc; exp_extra = []; exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); exp_env = env } | Pexp_apply(sfunct, sargs) -> @@ -1888,7 +1938,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = unify_var env (newvar()) funct.exp_type; rue { exp_desc = Texp_apply(funct, args); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = ty_res; exp_env = env } | P -> @@ -1918,9 +1968,9 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (sarg.pexp_loc, Garrigue_illegal "message"))) ty in rue { exp_desc = Texp_asyncsend (funct, arg); - exp_loc = sexp.pexp_loc; - exp_type = Predef.type_process [] ; - exp_env = env } + exp_loc = sexp.pexp_loc; exp_extra = []; + exp_type = Predef.type_process [] ; + exp_env = env } end | Pexp_match(sarg, caselist) -> begin_def (); @@ -1932,13 +1982,13 @@ and do_type_expect ?in_function ctx env sexp ty_expected = type_cases ctx env arg.exp_type ty_expected true loc caselist in re { - exp_desc = Texp_match(arg, cases, partial); - exp_loc = loc; - exp_type = - (match ctx with - | E -> instance env ty_expected - | P -> Predef.type_process reps); - exp_env = env } + exp_desc = Texp_match(arg, cases, partial); + exp_loc = loc; exp_extra = []; + exp_type = + (match ctx with + | E -> instance env ty_expected + | P -> Predef.type_process reps); + exp_env = env } | Pexp_try(sbody, caselist) -> check_expression ctx sexp ; let body = do_type_expect ctx env sbody ty_expected in @@ -1946,7 +1996,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = type_cases ctx env Predef.type_exn ty_expected false loc caselist in re { exp_desc = Texp_try(body, cases); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_tuple sexpl -> @@ -1959,7 +2009,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = in re { exp_desc = Texp_tuple expl; - exp_loc = loc; + exp_loc = loc; exp_extra = []; (* Keep sharing *) exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); exp_env = env } @@ -1979,7 +2029,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = 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_loc = loc; exp_extra = []; exp_type = ty_expected0; exp_env = env } | _ -> raise Not_found @@ -1990,7 +2040,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let arg_type = may_map (fun arg -> arg.exp_type) arg in rue { exp_desc = Texp_variant(l, arg); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; row_more = newvar (); row_bound = (); @@ -2002,24 +2052,25 @@ and do_type_expect ?in_function ctx env sexp ty_expected = | Pexp_record(lid_sexp_list, opt_sexp) -> check_expression ctx sexp ; let lbl_exp_list = - type_label_a_list env loc (type_label_exp true env loc ty_expected) + type_label_a_list env (type_label_exp true env loc ty_expected) lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with - ((lid, _) :: rem1, (lbl, _) :: rem2) -> + ((lid, _) :: rem1, (_, _, lbl, _) :: rem2) -> if List.mem lbl.lbl_pos seen_pos - then raise(Error(loc, Label_multiply_defined lid)) + then raise(Error(loc, Label_multiply_defined lid.txt)) else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2 | (_, _) -> () in check_duplicates [] lid_sexp_list lbl_exp_list; let opt_exp = match opt_sexp, lbl_exp_list with None, _ -> None - | Some sexp, (lbl, _) :: _ -> + | 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) + if List.for_all + (fun (_, _, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos) lbl_exp_list then begin let _, ty_arg1, ty_res1 = instance_label false lbl @@ -2038,10 +2089,10 @@ and do_type_expect ?in_function ctx env sexp ty_expected = in let num_fields = match lbl_exp_list with [] -> assert false - | (lbl,_)::_ -> Array.length lbl.lbl_all in + | (_,_, lbl,_)::_ -> Array.length lbl.lbl_all in if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin let present_indices = - List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in + List.map (fun (_,_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in let label_names = extract_label_names sexp env ty_expected in let rec missing_labels n = function [] -> [] @@ -2056,31 +2107,32 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Location.prerr_warning loc Warnings.Useless_record_with; re { exp_desc = Texp_record(lbl_exp_list, opt_exp); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_field(sarg, lid) -> check_expression ctx sexp ; let arg = do_type_exp ctx env sarg in - let label = Typetexp.find_label env loc lid in + let (label_path,label) = Typetexp.find_label env loc lid.txt in let (_, ty_arg, ty_res) = instance_label false label in unify_exp env arg ty_res; rue { - exp_desc = Texp_field(arg, label); - exp_loc = loc; + exp_desc = Texp_field(arg, label_path, lid, label); + exp_loc = loc; exp_extra = []; exp_type = ty_arg; exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> check_expression ctx sexp ; let record = do_type_exp ctx env srecord in - let label = Typetexp.find_label env loc lid in - let (label, newval) = - type_label_exp false env loc record.exp_type (label, snewval) in + let (label_path, label) = Typetexp.find_label env loc lid.txt in + let (label_path, label_loc, label, newval) = + type_label_exp false env loc record.exp_type + (label_path, lid, label, snewval) in if label.lbl_mut = Immutable then - raise(Error(loc, Label_not_mutable lid)); + raise(Error(loc, Label_not_mutable lid.txt)); rue { - exp_desc = Texp_setfield(record, label, newval); - exp_loc = loc; + exp_desc = Texp_setfield(record, label_path, label_loc, label, newval); + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_array(sargl) -> @@ -2091,7 +2143,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let argl = List.map (fun sarg -> do_type_expect ctx env sarg ty) sargl in re { exp_desc = Texp_array argl; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_ifthenelse(scond, sifso, sifnot) -> @@ -2103,7 +2155,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let ifso = do_type_expect ctx env sifso Predef.type_unit in rue { exp_desc = Texp_ifthenelse(cond, ifso, None); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } | Some sifnot -> @@ -2112,8 +2164,8 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (* Keep sharing *) unify_exp env ifnot ifso.exp_type; re { - exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = loc; + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } end @@ -2125,10 +2177,10 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let rep1 = Typejoin.get_replies ifso in re { exp_desc = Texp_ifthenelse(cond, ifso, None); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = - Predef.type_process - (Typejoin.inter sexp.pexp_loc rep1 []); + Predef.type_process + (Typejoin.inter sexp.pexp_loc rep1 []); exp_env = env } with Typejoin.MissingRight id -> raise (Error (sifso.pexp_loc, ExtraReply id)) @@ -2140,12 +2192,12 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let repso = Typejoin.get_replies ifso and repnot = Typejoin.get_replies ifnot in re { - exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = sexp.pexp_loc; - exp_type = - Predef.type_process - (Typejoin.inter sexp.pexp_loc repso repnot) ; - exp_env = env } + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = sexp.pexp_loc; exp_extra=[]; + exp_type = + Predef.type_process + (Typejoin.inter sexp.pexp_loc repso repnot) ; + exp_env = env } with | Typejoin.MissingRight id -> raise (Error (sifnot.pexp_loc, MissingReply id)) @@ -2161,69 +2213,70 @@ and do_type_expect ?in_function ctx env sexp ty_expected = | P -> do_type_expect E env sexp1 Predef.type_unit in let exp2 = do_type_expect ctx env sexp2 ty_expected in re { - exp_desc = Texp_sequence(exp1, exp2); - exp_loc = loc; - exp_type = exp2.exp_type; - exp_env = env } + exp_desc = Texp_sequence(exp1, exp2); + exp_loc = loc; exp_extra = []; + exp_type = exp2.exp_type; + exp_env = env } | Pexp_while(scond, sbody) -> check_expression ctx sexp; let cond = do_type_expect E env scond Predef.type_bool in let body = type_statement env sbody in rue { exp_desc = Texp_while(cond, body); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_for(param, slow, shigh, dir, sbody) -> let low = do_type_expect E env slow Predef.type_int in let high = do_type_expect E env shigh Predef.type_int in let (id, new_env) = - Env.enter_value param {val_type = instance_def Predef.type_int; - val_kind = Val_reg; - val_loc = loc; - } env + Env.enter_value param.txt {val_type = instance_def Predef.type_int; + val_kind = Val_reg; Types.val_loc = loc; } env ~check:(fun s -> Warnings.Unused_for_index s) in begin match ctx with | E -> let body = type_statement new_env sbody in rue { - exp_desc = Texp_for(id, low, high, dir, body); - exp_loc = loc; - exp_type = instance_def Predef.type_unit; - exp_env = env } + exp_desc = Texp_for(id, param, low, high, dir, body); + exp_loc = loc; exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_env = env } | P -> (* Remove continuation, so as to statically enforce unique replies *) let new_env = Env.remove_continuations new_env in let body = do_type_exp ctx new_env sbody in re { - exp_desc = Texp_for(id, low, high, dir, body); - exp_loc = loc; - exp_type = Predef.type_process [] ; - exp_env = env } + exp_desc = Texp_for(id, param, low, high, dir, body); + exp_loc = loc; exp_extra = []; + exp_type = Predef.type_process [] ; + exp_env = env } end | Pexp_constraint(sarg, sty, sty') -> check_expression ctx sexp; let separate = true (* always separate, 1% slowdown for lablgtk *) (* !Clflags.principal || Env.has_local_constraints env *) in - let (arg, ty') = + let (arg, ty',cty,cty') = match (sty, sty') with (None, None) -> (* Case actually unused *) let arg = do_type_exp ctx env sarg in - (arg, arg.exp_type) + (arg, arg.exp_type,None,None) | (Some sty, None) -> if separate then begin_def (); - let ty = Typetexp.transl_simple_type env false sty in + let cty = Typetexp.transl_simple_type env false sty in + let ty = cty.ctyp_type in if separate then begin end_def (); generalize_structure ty; - (type_argument env sarg ty (instance env ty), instance env ty) + (type_argument env sarg ty (instance env ty), + instance env ty, Some cty, None) end else - (type_argument env sarg ty ty, ty) + (type_argument env sarg ty ty, ty, Some cty, None) | (None, Some sty') -> - let (ty', force) = + let (cty', force) = Typetexp.transl_simple_type_delayed env sty' in + let ty' = cty'.ctyp_type in if separate then begin_def (); let arg = do_type_exp ctx env sarg in let gen = @@ -2236,7 +2289,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = end else true in begin match arg.exp_desc, !self_coercion, (repr ty').desc with - Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, + Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> (* prerr_endline "self coercion"; *) r := loc :: !r; @@ -2269,14 +2322,16 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Coercion_failure(ty', full_expand env ty', trace, b))) end end; - (arg, ty') + (arg, ty', None, Some cty') | (Some sty, Some sty') -> if separate then begin_def (); - let (ty, force) = + let (cty, force) = Typetexp.transl_simple_type_delayed env sty - and (ty', force') = + and (cty', force') = Typetexp.transl_simple_type_delayed env sty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in begin try let force'' = subtype env ty ty' in force (); force' (); force'' () @@ -2287,40 +2342,43 @@ and do_type_expect ?in_function ctx env sexp ty_expected = end_def (); generalize_structure ty; generalize_structure ty'; - (type_argument env sarg ty (instance env ty), instance env ty') + (type_argument env sarg ty (instance env ty), + instance env ty', Some cty, Some cty') end else - (type_argument env sarg ty ty, ty') + (type_argument env sarg ty ty, ty', Some cty, Some cty') in rue { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; exp_type = ty'; - exp_env = env } + exp_env = env; + exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra; + } | Pexp_when(scond, sbody) -> check_expression ctx sexp; let cond = do_type_expect E env scond Predef.type_bool in let body = do_type_expect ctx env sbody ty_expected in re { - exp_desc = Texp_when(cond, body); - exp_loc = loc; - exp_type = body.exp_type; - exp_env = env } + exp_desc = Texp_when(cond, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_env = env } | Pexp_send (e, met) -> check_expression ctx sexp ; if !Clflags.principal then begin_def (); let obj = do_type_exp E env e in begin try - let (exp, typ) = + let (meth, exp, typ) = match obj.exp_desc with - Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) -> + Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) -> let (id, typ) = filter_self_method env met Private meths privty in if is_Tvar (repr typ) then Location.prerr_warning loc (Warnings.Undeclared_virtual_method met); - (Texp_send(obj, Tmeth_val id), typ) - | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) -> + (Tmeth_val id, None, typ) + | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) -> let method_id = begin try List.assoc met methods with Not_found -> raise(Error(e.pexp_loc, Undefined_inherited_method met)) @@ -2339,25 +2397,31 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let (obj_ty, res_ty) = filter_arrow env method_type "" in unify env obj_ty desc.val_type; 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_loc = Location.none; - }); - exp_loc = loc; + let exp = + Texp_apply({exp_desc = + Texp_ident(Path.Pident method_id, lid, + {val_type = method_type; + val_kind = Val_reg; + Types.val_loc = Location.none}); + exp_loc = loc; exp_extra = []; exp_type = method_type; - exp_env = env }, - [Some {exp_desc = Texp_ident(path, desc); - exp_loc = obj.exp_loc; - exp_type = desc.val_type; - exp_env = env }, - Required]), - typ) + exp_env = env}, + ["", + Some {exp_desc = Texp_ident(path, lid, desc); + exp_loc = obj.exp_loc; exp_extra = []; + exp_type = desc.val_type; + exp_env = env}, + Required]) + in + (Tmeth_name met, Some (re {exp_desc = exp; + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_env = env}), typ) | _ -> assert false end | _ -> - (Texp_send(obj, Tmeth_name met), + (Tmeth_name met, None, filter_method env met Public obj.exp_type) in if !Clflags.principal then begin @@ -2383,57 +2447,58 @@ and do_type_expect ?in_function ctx env sexp ty_expected = assert false in rue { - exp_desc = exp; - exp_loc = loc; - exp_type = typ; - exp_env = env } + exp_desc = Texp_send(obj, meth, exp); + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_env = env } with Unify _ -> raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met))) end | Pexp_new cl -> check_expression ctx sexp ; - let (cl_path, cl_decl) = Typetexp.find_class env loc cl in + let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in begin match cl_decl.cty_new with None -> - raise(Error(loc, Virtual_class cl)) + raise(Error(loc, Virtual_class cl.txt)) | Some ty -> rue { - exp_desc = Texp_new (cl_path, cl_decl); - exp_loc = loc; + exp_desc = Texp_new (cl_path, cl, cl_decl); + exp_loc = loc; exp_extra = []; exp_type = instance_def ty; exp_env = env } end | Pexp_setinstvar (lab, snewval) -> check_expression ctx sexp ; begin try - let (path, desc) = Env.lookup_value (Longident.Lident lab) env in + let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in match desc.val_kind with Val_ivar (Mutable, cl_num) -> - let newval = do_type_expect E env snewval (instance env desc.val_type) in + let newval = + do_type_expect ctx env snewval (instance env desc.val_type) in let (path_self, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in rue { - exp_desc = Texp_setinstvar(path_self, path, newval); - exp_loc = loc; + exp_desc = Texp_setinstvar(path_self, path, lab, newval); + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Val_ivar _ -> - raise(Error(loc,Instance_variable_not_mutable(true,lab))) + raise(Error(loc,Instance_variable_not_mutable(true,lab.txt))) | _ -> - raise(Error(loc,Instance_variable_not_mutable(false,lab))) + raise(Error(loc,Instance_variable_not_mutable(false,lab.txt))) with Not_found -> - raise(Error(loc, Unbound_instance_variable lab)) + raise(Error(loc, Unbound_instance_variable lab.txt)) end | Pexp_override lst -> check_expression ctx sexp ; let _ = List.fold_right (fun (lab, _) l -> - if List.exists ((=) lab) l then + if List.exists (fun l -> l.txt = lab.txt) l then raise(Error(loc, - Value_multiply_overridden lab)); + Value_multiply_overridden lab.txt)); lab::l) lst [] in @@ -2448,17 +2513,17 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (path_self, _) -> let type_override (lab, snewval) = begin try - let (id, _, _, ty) = Vars.find lab !vars in - (Path.Pident id, do_type_expect E env snewval (instance env ty)) + let (id, _, _, ty) = Vars.find lab.txt !vars in + (Path.Pident id, lab, do_type_expect ctx env snewval (instance env ty)) with Not_found -> - raise(Error(loc, Unbound_instance_variable lab)) + raise(Error(loc, Unbound_instance_variable lab.txt)) end in let modifs = List.map type_override lst in rue { exp_desc = Texp_override(path_self, modifs); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = self_ty; exp_env = env } | _ -> @@ -2471,7 +2536,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = 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 + let (id, new_env) = Env.enter_module name.txt modl.mod_type env in Ctype.init_def(Ident.current_time()); Typetexp.widen context; let body = do_type_expect ctx new_env sbody ty_expected in @@ -2485,30 +2550,30 @@ and do_type_expect ?in_function ctx env sexp ty_expected = begin try Ctype.unify_var new_env ty body.exp_type with Unify _ -> - raise(Error(loc, Scoping_let_module(name, body.exp_type))) + raise(Error(loc, Scoping_let_module(name.txt, body.exp_type))) end; re { - exp_desc = Texp_letmodule(id, modl, body); - exp_loc = loc; - exp_type = ty; - exp_env = env } + exp_desc = Texp_letmodule(id, name, modl, body); + exp_loc = loc; exp_extra = []; + exp_type = ty; + exp_env = env } | Pexp_assert (e) -> check_expression ctx sexp ; let cond = do_type_expect ctx 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; - } + exp_desc = Texp_assert (cond); + exp_loc = loc; exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_env = env; + } | Pexp_assertfalse -> check_expression ctx sexp ; re { - exp_desc = Texp_assertfalse; - exp_loc = loc; - exp_type = instance env ty_expected; - exp_env = env; - } + exp_desc = Texp_assertfalse; + exp_loc = loc; exp_extra = []; + exp_type = instance env ty_expected; + exp_env = env; + } | Pexp_lazy e -> check_expression ctx sexp ; let ty = newgenvar () in @@ -2516,28 +2581,28 @@ and do_type_expect ?in_function ctx env sexp ty_expected = unify_exp_types loc env to_unify ty_expected; let arg = do_type_expect ctx env e ty in re { - exp_desc = Texp_lazy arg; - exp_loc = loc; - exp_type = instance env ty_expected; - exp_env = env; - } + exp_desc = Texp_lazy arg; + exp_loc = loc; exp_extra = []; + exp_type = instance env ty_expected; + exp_env = env; + } | Pexp_object s -> check_expression ctx sexp ; let desc, sign, meths = !type_object env loc s in rue { - exp_desc = Texp_object (desc, sign, meths); - exp_loc = loc; - exp_type = sign.cty_self; - exp_env = env; - } + exp_desc = Texp_object (desc, (*sign,*) meths); + exp_loc = loc; exp_extra = []; + exp_type = sign.cty_self; + exp_env = env; + } | Pexp_poly(sbody, sty) -> check_expression ctx sexp ; if !Clflags.principal then begin_def (); - let ty = - match sty with None -> repr ty_expected + let ty, cty = + match sty with None -> repr ty_expected, None | Some sty -> - let ty = Typetexp.transl_simple_type env false sty in - repr ty + let cty = Typetexp.transl_simple_type env false sty in + repr cty.ctyp_type, Some cty in if !Clflags.principal then begin end_def (); @@ -2545,11 +2610,11 @@ and do_type_expect ?in_function ctx env sexp ty_expected = end; if sty <> None then unify_exp_types loc env (instance env ty) (instance env ty_expected); - begin + let exp = match (expand_head env ty).desc with Tpoly (ty', []) -> let exp = do_type_expect ctx env sbody ty' in - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tpoly (ty', tl) -> (* One more level to generalize locally *) begin_def (); @@ -2562,16 +2627,20 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let exp = do_type_expect ctx env sbody ty'' in end_def (); check_univars env false "method" exp ty_expected vars; - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tvar _ -> let exp = do_type_exp ctx env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; - re exp + exp | _ -> assert false - end + in + re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra } | Pexp_newtype(name, sbody) -> check_expression ctx sexp ; + let ty = newvar () in + (* remember original level *) + begin_def (); (* Create a fake abstract type declaration for name. *) let level = get_current_level () in let decl = { @@ -2585,9 +2654,6 @@ and do_type_expect ?in_function ctx env sexp ty_expected = 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()); @@ -2614,7 +2680,8 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (* non-expansive if the body is non-expansive, so we don't introduce any new extra node in the typed AST. *) - rue { body with exp_loc = sexp.pexp_loc; exp_type = ety } + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = (Texp_newtype name, loc) :: body.exp_extra } | Pexp_pack m -> check_expression ctx sexp ; let (p, nl, tl) = @@ -2633,30 +2700,35 @@ and do_type_expect ?in_function ctx env sexp 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 = newty (Tpackage (p, nl, tl')); - exp_env = env } + exp_desc = Texp_pack modl; + exp_loc = loc; exp_extra = []; + exp_type = newty (Tpackage (p, nl, tl')); + exp_env = env } | Pexp_open (lid, e) -> - do_type_expect ctx (!type_open env sexp.pexp_loc lid) e ty_expected + let (path, newenv) = !type_open env sexp.pexp_loc lid in + let exp = do_type_expect ctx newenv e ty_expected in + { exp with + exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra; + } (*>JOCAML *) (* Continuation scope is restricted to P in - P & P, let D in P, match E (| p -> P)+, if e then P (else P)? - def D in P. - To achieve this it suffices to remove continuations from typing env - for typing D in def D in _ and for P in spawn P only. - Also for P in for .. do P done. -*) + P & P, let D in P, match E (| p -> P)+, if e then P (else P)? + def D in P. + To achieve this it suffices to remove continuations from typing env + for typing D in def D in _ and for P in spawn P only. + Also for P in for .. do P done. + *) | Pexp_spawn sarg -> check_expression ctx sexp ; let arg = do_type_exp P (Env.remove_continuations env) sarg in rue { exp_desc = Texp_spawn arg; - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env; } | Pexp_par (se1,se2) -> + check_process ctx sexp ; let e1 = do_type_exp P env se1 and e2 = do_type_exp P env se2 in begin try @@ -2664,27 +2736,27 @@ and do_type_expect ?in_function ctx env sexp ty_expected = and konts2 = Typejoin.get_replies e2 in re { exp_desc = Texp_par (e1, e2); - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = Predef.type_process (Typejoin.delta konts1 konts2) ; exp_env = env; } with Typejoin.Double (id, loc1, loc2) -> raise (Error (sexp.pexp_loc, DoubleReply (id, loc1, loc2))) end -|Pexp_reply (sres,jid) -> - check_process ctx sexp ; - let lid = Longident.parse jid.pjident_desc in + |Pexp_reply (sres,jid) -> + check_process ctx sexp ; + let lid = Longident.parse jid.txt in let path,ty = try let path,desc = Env.lookup_continuation lid env in desc.continuation_kind <- true ; path, desc.continuation_type with Not_found -> - raise(Error(jid.pjident_loc, Unbound_continuation lid)) in + raise(Error(jid.loc, Unbound_continuation lid)) in let res = do_type_expect E env sres ty in let kid = match path with Path.Pident r -> r | _ -> assert false in re { exp_desc = Texp_reply (res, kid) ; - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = Predef.type_process [kid, sexp.pexp_loc]; exp_env = env; } | Pexp_def (sautos, sbody) -> @@ -2694,12 +2766,13 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let body = do_type_exp ctx new_env sbody in rue { exp_desc = Texp_def (autos, body); - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra=[]; exp_type = body.exp_type; exp_env = env } (*<JOCAML *) -and type_label_exp create env loc ty_expected (label, sarg) = +and type_label_exp create env loc ty_expected + (label_path, lid, label, sarg) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = !Clflags.principal || Env.has_local_constraints env in @@ -2714,7 +2787,7 @@ and type_label_exp create env loc ty_expected (label, sarg) = begin try unify env (instance_def ty_res) (instance env ty_expected) with Unify trace -> - raise(Error(loc , Label_mismatch(lid_of_label label, trace))) + raise (Error(lid.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 @@ -2724,8 +2797,10 @@ and type_label_exp create env loc ty_expected (label, sarg) = generalize_structure ty_arg end; if label.lbl_private = Private then - raise(Error(loc, if create then Private_type ty_expected - else Private_label (lid_of_label label, ty_expected))); + if create then + raise (Error(loc, Private_type ty_expected)) + else + raise (Error(lid.loc, 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 (instance env ty_arg) in @@ -2746,7 +2821,7 @@ and type_label_exp create env loc ty_expected (label, 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 env arg.exp_type}) + (label_path, lid, label, {arg with exp_type = instance env arg.exp_type}) and type_argument env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) @@ -2754,11 +2829,14 @@ and type_argument env sarg ty_expected' ty_expected = 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) -> - do_type_expect E 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 (); @@ -2793,17 +2871,23 @@ and type_argument env sarg ty_expected' ty_expected = (* eta-expand to avoid side effects *) let var_pair name ty = let id = Ident.create name in - {pat_desc = Tpat_var id; pat_type = ty; + {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; 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; val_loc = Location.none})} + {exp_type = ty; exp_loc = Location.none; exp_env = env; + exp_extra = []; + exp_desc = + Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), + {val_type = ty; val_kind = Val_reg; + Types.val_loc = Location.none})} in let eta_pat, eta_var = var_pair "eta" ty_arg in let func texp = { texp with exp_type = ty_fun; exp_desc = - Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc = - Texp_apply (texp, args@ - [Some eta_var, Required])}], + Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc = + Texp_apply (texp, + (List.map (fun (label, exp) -> + ("", label, exp)) args)@ + ["", Some eta_var, Required])}], Total) } in if warn then Location.prerr_warning texp.exp_loc (Warnings.Without_principality "eliminated optional argument"); @@ -2830,53 +2914,58 @@ and type_application env funct sargs = tvar || List.mem l ls in let ignored = ref [] in - let rec type_unknown_args args omitted ty_fun = function - [] -> - (List.map - (function None, x -> None, x | Some f, x -> Some (f ()), x) - (List.rev args), - 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 _ -> - let t1 = newvar () and t2 = newvar () in - let not_identity = function - Texp_ident(_,{val_kind=Val_prim - {Primitive.prim_name="%identity"}}) -> - false - | _ -> true - in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); - (t1, t2) - | Tarrow (l,t1,t2,_) when l = l1 - || !Clflags.classic && l1 = "" && not (is_optional l) -> - (t1, t2) - | td -> - let ty_fun = - match td with Tarrow _ -> newty td | _ -> ty_fun in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - Tarrow _ -> - if (!Clflags.classic || not (has_label l1 ty_fun)) then - raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res))) - else - raise(Error(funct.exp_loc, Incoherent_label_order)) - | _ -> - raise(Error(funct.exp_loc, Apply_non_function - (expand_head env funct.exp_type))) - in - let optional = if is_optional l1 then Optional else Required in - let arg1 () = - let arg1 = do_type_expect E env sarg1 ty1 in - if optional = Optional then - unify_exp env arg1 (type_option(newvar())); - arg1 - in - type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl + let rec type_unknown_args + (args : + (Asttypes.label * (unit -> Typedtree.expression) option * + Typedtree.optional) list) + omitted ty_fun = function + [] -> + (List.map + (function l, None, x -> l, None, x + | l, Some f, x -> l, Some (f ()), x) + (List.rev args), + 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 _ -> + let t1 = newvar () and t2 = newvar () in + let not_identity = function + Texp_ident(_,_,{val_kind=Val_prim + {Primitive.prim_name="%identity"}}) -> + false + | _ -> true + in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); + (t1, t2) + | Tarrow (l,t1,t2,_) when l = l1 + || !Clflags.classic && l1 = "" && not (is_optional l) -> + (t1, t2) + | td -> + let ty_fun = + match td with Tarrow _ -> newty td | _ -> ty_fun in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + Tarrow _ -> + if (!Clflags.classic || not (has_label l1 ty_fun)) then + raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res))) + else + raise(Error(funct.exp_loc, Incoherent_label_order)) + | _ -> + raise(Error(funct.exp_loc, Apply_non_function + (expand_head env funct.exp_type))) + in + let optional = if is_optional l1 then Optional else Required in + let arg1 () = + let arg1 = do_type_expect E env sarg1 ty1 in + if optional = Optional then + unify_exp env arg1 (type_option(newvar())); + arg1 + in + type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl in let ignore_labels = !Clflags.classic || @@ -2964,7 +3053,7 @@ 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_fun0 + type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0 ty_old sargs more_sargs | _ -> match sargs with @@ -2976,7 +3065,7 @@ and type_application env funct 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"}}), + Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}), ["", sarg] -> let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in let exp = do_type_expect E env sarg ty_arg in @@ -2987,7 +3076,7 @@ and type_application env funct sargs = add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; - ([Some exp, Required], ty_res) + (["", Some exp, Required], ty_res) | _ -> let ty = funct.exp_type in if ignore_labels then @@ -2996,8 +3085,8 @@ and type_application env funct sargs = type_args [] [] ty (instance env ty) ty sargs [] and type_construct env loc lid sarg explicit_arity ty_expected = - let constr = Typetexp.find_constructor env loc lid in - Env.mark_constructor env (Longident.last lid) constr; + let (path,constr) = Typetexp.find_constructor env loc lid.txt in + Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; let sargs = match sarg with None -> [] @@ -3006,14 +3095,14 @@ and type_construct env loc lid sarg explicit_arity ty_expected = | Some se -> [se] in if List.length sargs <> constr.cstr_arity then raise(Error(loc, Constructor_arity_mismatch - (lid, constr.cstr_arity, List.length sargs))); + (lid.txt, constr.cstr_arity, List.length sargs))); let separate = !Clflags.principal || Env.has_local_constraints env in if separate then (begin_def (); begin_def ()); let (ty_args, ty_res) = instance_constructor constr in let texp = re { - exp_desc = Texp_construct(constr, []); - exp_loc = loc; + exp_desc = Texp_construct(path, lid, constr, [],explicit_arity); + exp_loc = loc; exp_extra = []; exp_type = ty_res; exp_env = env } in if separate then begin @@ -3036,7 +3125,8 @@ and type_construct env loc lid sarg explicit_arity ty_expected = (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)} + { texp with + exp_desc = Texp_construct(path, lid, constr, args, explicit_arity) } (* Typing of statements (expressions whose values are discarded) *) @@ -3066,17 +3156,17 @@ and type_statement env sexp = (* Typing of match cases *) (* - Argument ty_res is unused when ctx is P, - instead the list of names replied to is returned, - as an additional 'reps' in typed_cases, partial, reps -*) + Argument ty_res is unused when ctx is P, + instead the list of names replied to is returned, + as an additional 'reps' in typed_cases, partial, reps + *) and type_cases ?in_function ctx 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"); *) +(* 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, @@ -3086,17 +3176,19 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = if has_gadts then begin (* raise level for existentials *) begin_def (); - Ident.set_current_time (get_current_level ()); + 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; *) +(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) let pat_env_list = List.map (fun (spat, sexp) -> @@ -3153,15 +3245,11 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = 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 = do_type_expect ?in_function ctx ext_env sexp ty_res' in +(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_res'; *) + let exp = do_type_expect E ?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; cases,[] | P -> (* No GADT ?? *) let cases = @@ -3176,10 +3264,10 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = | (_,fst)::rem -> let reps = Typejoin.get_replies fst in (* - Printf.eprintf "Replies: [%s]\n%!" - (String.concat "; " - (List.map (fun (id,_) -> Ident.name id) reps)) ; -*) + Printf.eprintf "Replies: [%s]\n%!" + (String.concat "; " + (List.map (fun (id,_) -> Ident.name id) reps)) ; + *) List.iter (fun (_, exp) -> try @@ -3221,7 +3309,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let is_fake_let = match spat_sexp_list with | [_, {pexp_desc=Pexp_match( - {pexp_desc=Pexp_ident(Longident.Lident "*opt*")},_)}] -> + {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] -> true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) | _ -> false @@ -3237,9 +3325,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) | _, 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, {ptyp_desc=Ptyp_poly([],sty); - ptyp_loc={sty.ptyp_loc with Location.loc_ghost=true}}); + {ppat_desc = Ppat_constraint (spat, sty); ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}} | _ -> spat) spat_sexp_list in @@ -3283,7 +3369,11 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) 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 rec_needed = ref false in + let warn_unused = + Warnings.is_active (check "") || Warnings.is_active (check_strict "") || + (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)) + in let pat_slot_list = (* Algorithm to detect unused declarations in recursive bindings: - During type checking of the definitions, we capture the 'value_used' @@ -3291,7 +3381,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) to the current definition (!current_slot). In effect, this creates a dependency graph between definitions. - - After type checking the definition (!current_slot = Mone), + - After type checking the definition (!current_slot = None), 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 @@ -3309,7 +3399,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) (* has one of the identifier of this pattern been used? *) let slot = ref [] in List.iter - (fun id -> + (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 @@ -3318,14 +3408,15 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) add_delayed_check (fun () -> if not !used then - Location.prerr_warning vd.val_loc + Location.prerr_warning vd.Types.val_loc ((if !some_used then check_strict else check) name) ); Env.set_value_used_callback name vd (fun () -> match !current_slot with - | Some slot -> slot := (name, vd) :: !slot + | Some slot -> + slot := (name, vd) :: !slot; rec_needed := true | None -> List.iter (fun (name, vd) -> Env.mark_value_used name vd) @@ -3361,6 +3452,10 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) | _ -> do_type_expect E exp_env sexp pat.pat_type) spat_sexp_list pat_slot_list in current_slot := None; + if is_recursive && not !rec_needed + && Warnings.is_active Warnings.Unused_rec_flag then + Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc + Warnings.Unused_rec_flag; List.iter2 (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp])) pat_list exp_list; @@ -3389,8 +3484,8 @@ and type_dispatcher names disp = Disp (d_id, chan, cls, par) and type_clause env names reac = - let g_id,(old,(actual_pats, gd)) = reac in - let (loc_clause,jpats,sexp),(pat_vars,pat_force) = old in + let g_id,(old,(actual_pats, gd)) = reac in + let (loc_clause,jpats,sexp),(pat_vars,pat_force) = old in (* First build environment for guarded process *) let conts = ref [] in @@ -3403,14 +3498,14 @@ and type_clause env names reac = conts := kdesc :: !conts; Env.add_continuation kid kdesc env - and add_pat_var (id, ty, loc, as_var) env = + and add_pat_var (id, ty, _name, loc, as_var) env = (* _name info forgotten *) let check = if as_var then fun s -> Warnings.Unused_var s else fun s -> Warnings.Unused_var_strict s in let e1 = Env.add_value ~check - id {val_type = ty; val_kind = Val_reg; val_loc = loc; } + id {val_type = ty; val_kind = Val_reg; Types.val_loc = loc; } env in Env.add_annot id (Annot.Iref_internal loc) e1 in @@ -3464,9 +3559,9 @@ and type_reac env names reac = Reac (type_clause env names reac) and type_fwd env names reac = Fwd (type_clause env names reac) and type_auto env - (my_loc, my_names, - (nchans, original, def_names), - (disps,reacs,fwds)) = + (my_loc, my_names, + (nchans, original, def_names), + (disps,reacs,fwds)) = let env = Env.remove_continuations env in let reacs = List.map (type_reac env def_names) reacs and fwds = List.map (type_fwd env def_names) fwds in @@ -3521,23 +3616,23 @@ and generalize_auto env auto = auto.jauto_names and add_auto_names p env names = - List.fold_left - (fun env (id,(ty,nat)) -> - if p id then - let kind = match nat with - | Chan (name,num)-> Val_channel (name,num) - | Alone g -> Val_alone g in - Env.add_value id - {val_type = ty; val_kind = kind; val_loc = Location.none; } env - else env) - env names + List.fold_left + (fun env (id,(ty,nat)) -> + if p id then + let kind = match nat with + | Chan (name,num)-> Val_channel (name,num) + | Alone g -> Val_alone g in + Env.add_value id + {val_type = ty; val_kind = kind; Types.val_loc = Location.none; } env + else env) + env names and add_auto_names_as_regular p env names = List.fold_left (fun env (id,(ty,_)) -> if p id then Env.add_value id - {val_type = ty; val_kind = Val_reg; val_loc = Location.none} env + {val_type = ty; val_kind = Val_reg; Types.val_loc = Location.none} env else env) env names @@ -3566,13 +3661,13 @@ and type_def toplevel env sautos scope = (fun env (_ , _, (_,original,names), _) -> let p id = List.mem id original in add_auto_names_as_regular p env names) - env names_lhs_list + env names_lhs_list else List.fold_left (fun env (_ , _, (_,original,names), _) -> let p id = List.mem id original in add_auto_names p env names) - env names_lhs_list in + env names_lhs_list in autos, final_env (* Got to export those *) @@ -3609,7 +3704,7 @@ let type_expression env sexp = 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 + let (path, desc) = Env.lookup_value lid.txt env in {exp with exp_type = desc.val_type} | _ -> exp @@ -3644,9 +3739,9 @@ let report_error ppf = function | Pattern_type_clash trace -> report_unification_error ppf trace (function ppf -> - fprintf ppf "This pattern matches values of type") + fprintf ppf "This pattern matches values of type") (function ppf -> - fprintf ppf "but a pattern was expected which matches values of type") + fprintf ppf "but a pattern was expected which matches values of type") | Multiply_bound_variable name -> fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars id -> @@ -3682,7 +3777,8 @@ let report_error ppf = function fprintf ppf "The record field label %a is defined several times" longident lid | Label_missing labels -> - let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in + let print_labels ppf = + List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in fprintf ppf "@[<hov>Some record field labels are undefined:%a@]" print_labels labels | Label_not_mutable lid -> @@ -3823,3 +3919,4 @@ let report_error ppf = function (*<JOCAML *) let () = Env.add_delayed_check_forward := add_delayed_check + diff --git a/typing/typecore.mli b/typing/typecore.mli index c4b9b5b368..bc22d4c1be 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -41,7 +41,7 @@ val type_joindefinition: val type_class_arg_pattern: string -> Env.t -> Env.t -> label -> Parsetree.pattern -> - Typedtree.pattern * (Ident.t * Ident.t * type_expr) list * + Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list * Env.t * Env.t val type_self_pattern: string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> @@ -82,7 +82,7 @@ type error = | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr | Label_multiply_defined of Longident.t - | Label_missing of string list + | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Incomplete_format of string | Bad_conversion of string * int * char @@ -130,13 +130,15 @@ val report_error: formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref +val type_open: (Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> - Typedtree.class_structure * class_signature * string list) ref + Typedtree.class_structure * Types.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 + (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 +val create_package_type : Location.t -> Env.t -> + Longident.t * (Longident.t * Parsetree.core_type) list -> + Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 3f59be0926..2890d0cac1 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -19,7 +19,6 @@ open Asttypes open Parsetree open Primitive open Types -open Typedtree open Typetexp type error = @@ -44,6 +43,8 @@ type error = | Unbound_type_var_exc of type_expr * type_expr | Varying_anonymous +open Typedtree + exception Error of Location.t * error (* Enter all declared types in the environment as abstract types *) @@ -125,11 +126,11 @@ module StringSet = end) let make_params sdecl = - try - List.map + try + List.map (function None -> Ctype.new_global_var ~name:"_" () - | Some x -> enter_type_variable true sdecl.ptype_loc x) + | Some x -> enter_type_variable true sdecl.ptype_loc x.txt) sdecl.ptype_params with Already_bound -> raise(Error(sdecl.ptype_loc, Repeated_parameter)) @@ -140,106 +141,132 @@ let transl_declaration env (name, sdecl) id = Ctype.begin_def (); let params = make_params sdecl in let cstrs = List.map - (fun (sty, sty', loc) -> - transl_simple_type env false sty, - transl_simple_type env false sty', loc) - sdecl.ptype_cstrs + (fun (sty, sty', loc) -> + transl_simple_type env false sty, + transl_simple_type env false sty', loc) + sdecl.ptype_cstrs in - let decl = - { type_params = params; - type_arity = List.length params; - type_kind = - begin match sdecl.ptype_kind with - Ptype_abstract -> Type_abstract - | Ptype_variant cstrs -> - let all_constrs = ref StringSet.empty in - List.iter - (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 - raise(Error(sdecl.ptype_loc, Too_many_constructors)); - 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 - (fun (name, mut, arg, loc) -> - if StringSet.mem name !all_labels then - raise(Error(sdecl.ptype_loc, Duplicate_label name)); - all_labels := StringSet.add name !all_labels) - lbls; - let lbls' = - List.map - (fun (name, mut, arg, loc) -> - let ty = transl_simple_type env true arg in - name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty) - lbls in - let rep = - if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' - then Record_float - else Record_regular in - Type_record(lbls', rep) - end; - type_private = sdecl.ptype_private; - type_manifest = - begin match sdecl.ptype_manifest with - None -> None - | Some sty -> - let no_row = not (is_fixed_type sdecl) in - 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 + let (tkind, kind) = + match sdecl.ptype_kind with + Ptype_abstract -> Ttype_abstract, Type_abstract + | Ptype_variant cstrs -> + let all_constrs = ref StringSet.empty in + List.iter + (fun ({ txt = 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 + raise(Error(sdecl.ptype_loc, Too_many_constructors)); + let make_cstr (lid, args, ret_type, loc) = + let name = Ident.create lid.txt in + match ret_type with + | None -> + (name, lid, List.map (transl_simple_type env true) args, None, loc) + | Some sty -> + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + let z = narrow () in + reset_type_variables (); + let args = List.map (transl_simple_type env false) args in + let ret_type = + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + let p = Path.Pident id in + match (Ctype.repr ty).desc with + Tconstr (p', _, _) when Path.same p p' -> ty + | _ -> + raise (Error (sty.ptyp_loc, Constraint_failed + (ty, Ctype.newconstr p params))) + in + widen z; + (name, lid, args, Some ret_type, loc) + in + let cstrs = List.map make_cstr cstrs in + Ttype_variant (List.map (fun (name, lid, ctys, _, loc) -> + name, lid, ctys, loc + ) cstrs), + Type_variant (List.map (fun (name, name_loc, ctys, option, loc) -> + name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs) + + | Ptype_record lbls -> + let all_labels = ref StringSet.empty in + List.iter + (fun ({ txt = name }, mut, arg, loc) -> + if StringSet.mem name !all_labels then + raise(Error(sdecl.ptype_loc, Duplicate_label name)); + all_labels := StringSet.add name !all_labels) + lbls; + let lbls = List.map (fun (name, mut, arg, loc) -> + let cty = transl_simple_type env true arg in + (Ident.create name.txt, name, mut, cty, loc) + ) lbls in + let lbls' = + List.map + (fun (name, name_loc, mut, cty, loc) -> + let ty = cty.ctyp_type in + name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty) + lbls in + let rep = + if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' + then Record_float + else Record_regular in + Ttype_record lbls, Type_record(lbls', rep) + in + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let no_row = not (is_fixed_type sdecl) in + let cty = transl_simple_type env no_row sty in + Some cty, Some cty.ctyp_type + in + let decl = + { type_params = params; + type_arity = List.length params; + type_kind = kind; + type_private = sdecl.ptype_private; + type_manifest = man; + 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, Inconsistent_constraint tr))) - cstrs; - Ctype.end_def (); + List.iter + (fun (cty, cty', loc) -> + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + try Ctype.unify env ty ty' with Ctype.Unify tr -> + raise(Error(loc, Inconsistent_constraint tr))) + cstrs; + Ctype.end_def (); (* Add abstract row *) - if is_fixed_type sdecl then begin - let (p, _) = - try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env - with Not_found -> assert false in - set_fixed_row env sdecl.ptype_loc p decl - end; + if is_fixed_type sdecl then begin + let (p, _) = + try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env + with Not_found -> assert false in + set_fixed_row env sdecl.ptype_loc p decl + end; (* Check for cyclic abbreviations *) - begin match decl.type_manifest with None -> () - | Some ty -> - if Ctype.cyclic_abbrev env id ty then - raise(Error(sdecl.ptype_loc, Recursive_abbrev name)); - end; - (id, decl) + begin match decl.type_manifest with None -> () + | Some ty -> + if Ctype.cyclic_abbrev env id ty then + raise(Error(sdecl.ptype_loc, Recursive_abbrev name.txt)); + end; + let tdecl = { + typ_params = sdecl.ptype_params; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_variance = sdecl.ptype_variance; + typ_private = sdecl.ptype_private; + } in + (id, name, tdecl) (* Generalize a type declaration *) @@ -303,7 +330,7 @@ let check_constraints env (_, sdecl) (_, decl) = let (styl, sret_type) = try let (_, sty, sret_type, _) = - List.find (fun (n,_,_,_) -> n = name) pl + List.find (fun (n,_,_,_) -> n.txt = Ident.name name) pl in (sty, sret_type) with Not_found -> assert false in List.iter2 @@ -325,11 +352,11 @@ let check_constraints env (_, sdecl) (_, decl) = let rec get_loc name = function [] -> assert false | (name', _, sty, _) :: tl -> - if name = name' then sty.ptyp_loc else get_loc name tl + if name = name'.txt then sty.ptyp_loc else get_loc name tl in List.iter (fun (name, _, ty) -> - check_constraints_rec env (get_loc name pl) visited ty) + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) l end; begin match decl.type_manifest with @@ -359,8 +386,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 ~equality:true env + (Path.last path) decl' + id (Subst.type_declaration (Subst.add_type id path Subst.identity) decl) in @@ -373,12 +402,25 @@ let check_abbrev env (_, sdecl) (id, decl) = end | _ -> () +(* Check that recursion is well-founded *) + +let check_well_founded env loc path decl = + Misc.may + (fun body -> + try Ctype.correct_abbrev env path decl.type_params body with + | Ctype.Recursive_abbrev -> + raise(Error(loc, Recursive_abbrev (Path.name path))) + | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))) + decl.type_manifest + (* Check for ill-defined abbrevs *) let check_recursion env loc path decl to_check = (* to_check is true for potentially mutually recursive paths. (path, decl) is the type declaration to be checked. *) + if decl.type_params = [] then () else + let visited = ref [] in let rec check_regular cpath args prev_exp ty = @@ -415,29 +457,22 @@ let check_recursion env loc path decl to_check = end; List.iter (check_regular cpath args prev_exp) args' | Tpoly (ty, tl) -> - let (_, ty) = Ctype.instance_poly false tl ty in + let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in check_regular cpath args prev_exp ty | _ -> Btype.iter_type_expr (check_regular cpath args prev_exp) ty end in - match decl.type_manifest with - | None -> () - | Some body -> - (* Check that recursion is well-founded *) - begin try - Ctype.correct_abbrev env path decl.type_params body - with Ctype.Recursive_abbrev -> - raise(Error(loc, Recursive_abbrev (Path.name path))) - | Ctype.Unify trace -> raise(Error(loc, Type_clash trace)) - end; - (* Check that recursion is regular *) - if decl.type_params = [] then () else + Misc.may + (fun body -> let (args, body) = - Ctype.instance_parameterized_type decl.type_params body in - check_regular path args [] body + Ctype.instance_parameterized_type + ~keep_names:true decl.type_params body in + check_regular path args [] body) + decl.type_manifest -let check_abbrev_recursion env id_loc_list (id, decl) = +let check_abbrev_recursion env id_loc_list (id, _, tdecl) = + let decl = tdecl.typ_type in check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl (function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false) @@ -519,7 +554,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)) @@ -600,7 +635,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl {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)) @@ -664,8 +699,8 @@ let init_variance (id, decl) = let compute_variance_decls env cldecls = let decls, required = List.fold_right - (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) (decls, req) -> - (obj_id, obj_abbr) :: decls, required :: req) + (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) -> + (obj_id, obj_abbr) :: decls, (ci.ci_variance, ci.ci_loc) :: req) cldecls ([],[]) in let variances = List.map init_variance decls in @@ -688,20 +723,21 @@ let check_duplicates name_sdecl_list = List.iter (fun (cname, _, _, loc) -> try - let name' = Hashtbl.find constrs cname in + let name' = Hashtbl.find constrs cname.txt in Location.prerr_warning loc (Warnings.Duplicate_definitions - ("constructor", cname, name', name)) - with Not_found -> Hashtbl.add constrs cname name) + ("constructor", cname.txt, name', name.txt)) + with Not_found -> Hashtbl.add constrs cname.txt name.txt) cl | Ptype_record fl -> List.iter (fun (cname, _, _, loc) -> try - let name' = Hashtbl.find labels cname in + let name' = Hashtbl.find labels cname.txt in Location.prerr_warning loc - (Warnings.Duplicate_definitions ("label", cname, name', name)) - with Not_found -> Hashtbl.add labels cname name) + (Warnings.Duplicate_definitions + ("label", cname.txt, name', name.txt)) + with Not_found -> Hashtbl.add labels cname.txt name.txt) fl | Ptype_abstract -> ()) name_sdecl_list @@ -729,15 +765,15 @@ let transl_type_decl env name_sdecl_list = in let name_sdecl_list = List.map - (fun (name,sdecl) -> - name^"#row", + (fun (name, sdecl) -> + mkloc (name.txt ^"#row") name.loc, {sdecl with ptype_kind = Ptype_abstract; ptype_manifest = None}) fixed_types @ name_sdecl_list in (* Create identifiers. *) let id_list = - List.map (fun (name, _) -> Ident.create name) name_sdecl_list + List.map (fun (name, _) -> Ident.create name.txt) name_sdecl_list in (* Since we've introduced fresh idents, make sure the definition @@ -765,12 +801,19 @@ let transl_type_decl env name_sdecl_list = (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 () + | 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 + let transl_declaration name_sdecl (id, slot) = + current_slot := slot; transl_declaration temp_env name_sdecl id in + let tdecls = + List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in + let decls = + List.map (fun (id, name_loc, tdecl) -> (id, tdecl.typ_type)) tdecls in current_slot := None; (* Check for duplicates *) check_duplicates name_sdecl_list; @@ -792,21 +835,26 @@ let transl_type_decl env name_sdecl_list = List.map2 (fun id (_,sdecl) -> (id, sdecl.ptype_loc)) id_list name_sdecl_list in - List.iter (check_abbrev_recursion newenv id_loc_list) decls; + List.iter (fun (id, decl) -> + check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl) + decls; + List.iter (check_abbrev_recursion newenv id_loc_list) tdecls; (* Check that all type variable are closed *) List.iter2 - (fun (_, sdecl) (id, decl) -> + (fun (_, sdecl) (id, _, tdecl) -> + let decl = tdecl.typ_type in match Ctype.closed_type_decl decl with Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) | None -> ()) - name_sdecl_list decls; + name_sdecl_list tdecls; (* Check re-exportation *) List.iter2 (check_abbrev newenv) name_sdecl_list decls; (* Check that constraints are enforced *) List.iter2 (check_constraints newenv) name_sdecl_list decls; (* Name recursion *) let decls = - List.map2 (fun (_, sdecl) (id, decl) -> id, name_recursion sdecl id decl) + List.map2 (fun (_, sdecl) (id, decl) -> + id, name_recursion sdecl id decl) name_sdecl_list decls in (* Add variances to the environment *) @@ -817,41 +865,49 @@ let transl_type_decl env name_sdecl_list = let final_decls, final_env = compute_variance_fixpoint env decls required (List.map init_variance decls) in + let final_decls = List.map2 (fun (id, name_loc, tdecl) (id2, decl) -> + (id, name_loc, { tdecl with typ_type = decl }) + ) tdecls final_decls in (* Done *) (final_decls, final_env) (* Translate an exception declaration *) let transl_closed_type env sty = - let ty = transl_simple_type env true sty in + let cty = transl_simple_type env true sty in + let ty = cty.ctyp_type in + let ty = match Ctype.free_variables ty with | [] -> ty | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty))) + in + { cty with ctyp_type = ty } let transl_exception env loc excdecl = reset_type_variables(); Ctype.begin_def(); - let types = List.map (transl_closed_type env) excdecl in + let ttypes = List.map (transl_closed_type env) excdecl in Ctype.end_def(); + let types = List.map (fun cty -> cty.ctyp_type) ttypes in List.iter Ctype.generalize types; - { exn_args = types; - exn_loc = loc } + let exn_decl = { exn_args = types; Types.exn_loc = loc } in + { exn_params = ttypes; exn_exn = exn_decl; Typedtree.exn_loc = loc } (* Translate an exception rebinding *) let transl_exn_rebind env loc lid = - let cdescr = + let (path, cdescr) = try Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in - Env.mark_constructor env (Longident.last lid) cdescr; + Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; match cdescr.cstr_tag with Cstr_exception (path, _) -> - (path, {exn_args = cdescr.cstr_args; exn_loc = loc}) + (path, {exn_args = cdescr.cstr_args; Types.exn_loc = loc}) | _ -> raise(Error(loc, Not_an_exception lid)) (* exception globalization, just check lid is an exception constructor *) let transl_exn_global env loc lid = - let cdescr = + let _,cdescr = try Env.lookup_constructor lid env with Not_found -> @@ -862,10 +918,12 @@ let transl_exn_global env loc lid = (* Translate a value declaration *) let transl_value_decl env loc valdecl = - let ty = Typetexp.transl_type_scheme env valdecl.pval_type in + let cty = Typetexp.transl_type_scheme env valdecl.pval_type in + let ty = cty.ctyp_type in + let v = match valdecl.pval_prim with [] -> - { val_type = ty; val_kind = Val_reg; val_loc = loc } + { val_type = ty; val_kind = Val_reg; Types.val_loc = loc } | decl -> let arity = Ctype.arity ty in if arity = 0 then @@ -875,11 +933,16 @@ let transl_value_decl env loc 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_loc = loc } + { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc } + in + { val_desc = cty; val_val = v; + val_prim = valdecl.pval_prim; + val_loc = valdecl.pval_loc; } (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) let transl_with_constraint env id row_path orig_decl sdecl = + Env.mark_type_used (Ident.name id) orig_decl; reset_type_variables(); Ctype.begin_def(); let params = make_params sdecl in @@ -887,30 +950,32 @@ let transl_with_constraint env id row_path orig_decl sdecl = let arity_ok = List.length params = orig_decl.type_arity in if arity_ok then List.iter2 (Ctype.unify_var env) params orig_decl.type_params; - let orig_decl = Ctype.instance_declaration orig_decl in - let arity_ok = List.length params = orig_decl.type_arity in - if arity_ok then - List.iter2 (Ctype.unify_var env) params orig_decl.type_params; - List.iter + let constraints = List.map (function (ty, ty', loc) -> try - Ctype.unify env (transl_simple_type env false ty) - (transl_simple_type env false ty') + let cty = transl_simple_type env false ty in + let cty' = transl_simple_type env false ty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + Ctype.unify env ty ty'; + (cty, cty', loc) with Ctype.Unify tr -> raise(Error(loc, Inconsistent_constraint tr))) - sdecl.ptype_cstrs; + sdecl.ptype_cstrs + in let no_row = not (is_fixed_type sdecl) in + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let cty = transl_simple_type env no_row sty in + Some cty, Some cty.ctyp_type + in let decl = { type_params = params; type_arity = List.length params; type_kind = if arity_ok then orig_decl.type_kind else Type_abstract; type_private = sdecl.ptype_private; - type_manifest = - begin match sdecl.ptype_manifest with - None -> None - | Some sty -> - Some(transl_simple_type env no_row sty) - end; + type_manifest = man; type_variance = []; type_newtype_level = None; type_loc = sdecl.ptype_loc; @@ -929,7 +994,16 @@ let transl_with_constraint env id row_path orig_decl sdecl = (sdecl.ptype_variance, sdecl.ptype_loc)} in Ctype.end_def(); generalize_decl decl; - decl + { + typ_params = sdecl.ptype_params; + typ_type = decl; + typ_cstrs = constraints; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = Ttype_abstract; + typ_variance = sdecl.ptype_variance; + typ_private = sdecl.ptype_private; + } (* Approximate a type declaration: just make all types abstract *) @@ -954,7 +1028,7 @@ let abstract_type_decl arity = let approx_type_decl env name_sdecl_list = List.map (fun (name, sdecl) -> - (Ident.create name, + (Ident.create name.txt, abstract_type_decl (List.length sdecl.ptype_params))) name_sdecl_list @@ -964,6 +1038,7 @@ let approx_type_decl env name_sdecl_list = let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) + check_well_founded env loc path decl; check_recursion env loc path decl (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) @@ -1058,12 +1133,12 @@ let report_error ppf = function let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> - explain_unbound ppf ty tl (fun (_,tl,_) -> - Btype.newgenty (Ttuple tl)) - "case" (fun (lab,_,_) -> lab ^ " of ") + explain_unbound ppf ty tl (fun (_,tl,_) -> + Btype.newgenty (Ttuple tl)) + "case" (fun (lab,_,_) -> Ident.name lab ^ " of ") | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun (_,_,t) -> t) - "field" (fun (lab,_,_) -> lab ^ ": ") + "field" (fun (lab,_,_) -> Ident.name lab ^ ": ") | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 9a3e543851..16cf7b9043 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -14,14 +14,17 @@ (* Typing of type definitions and primitive definitions *) +open Asttypes open Types open Format val transl_type_decl: - Env.t -> (string * Parsetree.type_declaration) list -> - (Ident.t * type_declaration) list * Env.t + Env.t -> (string loc * Parsetree.type_declaration) list -> + (Ident.t * string Asttypes.loc * Typedtree.type_declaration) list * Env.t + val transl_exception: - Env.t -> Location.t -> Parsetree.exception_declaration -> exception_declaration + Env.t -> Location.t -> + Parsetree.exception_declaration -> Typedtree.exception_declaration val transl_exn_rebind: Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration @@ -32,15 +35,16 @@ val transl_exn_global: (*<JOCAML*) val transl_value_decl: - Env.t -> Location.t -> Parsetree.value_description -> value_description + Env.t -> Location.t -> + Parsetree.value_description -> Typedtree.value_description val transl_with_constraint: - Env.t -> Ident.t -> Path.t option -> type_declaration -> - Parsetree.type_declaration -> type_declaration + Env.t -> Ident.t -> Path.t option -> Types.type_declaration -> + Parsetree.type_declaration -> Typedtree.type_declaration val abstract_type_decl: int -> type_declaration val approx_type_decl: - Env.t -> (string * Parsetree.type_declaration) list -> + Env.t -> (string loc * Parsetree.type_declaration) list -> (Ident.t * type_declaration) list val check_recmod_typedecl: Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit @@ -51,10 +55,11 @@ val is_fixed_type : Parsetree.type_declaration -> bool (* for typeclass.ml *) val compute_variance_decls: Env.t -> - (Ident.t * type_declaration * type_declaration * class_declaration * - cltype_declaration * ((bool * bool) list * Location.t)) list -> - (type_declaration * type_declaration * class_declaration * - cltype_declaration) list + (Ident.t * Types.type_declaration * Types.type_declaration * + Types.class_declaration * Types.class_type_declaration * + 'a Typedtree.class_infos) list -> + (Types.type_declaration * Types.type_declaration * + Types.class_declaration * Types.class_type_declaration) list type error = Repeated_parameter diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 6aea460b78..3620a33421 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -20,65 +20,87 @@ open Types (* Value expressions for the core language *) +type partial = Partial | Total +type optional = Required | Optional + type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; + pat_extra : (pat_extra * Location.t) list; pat_type: type_expr; mutable pat_env: Env.t } +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_unpack + and pattern_desc = Tpat_any - | Tpat_var of Ident.t - | Tpat_alias of pattern * Ident.t + | Tpat_var of Ident.t * string loc + | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list - | Tpat_construct of constructor_description * pattern list + | Tpat_construct of + Path.t * Longident.t loc * constructor_description * pattern list * bool | Tpat_variant of label * pattern option * row_desc ref - | Tpat_record of (label_description * pattern) list + | Tpat_record of + (Path.t * Longident.t loc * label_description * pattern) list * + closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern -type partial = Partial | Total -type optional = Required | Optional - -type expression = +and expression = { exp_desc: expression_desc; exp_loc: Location.t; + exp_extra : (exp_extra * Location.t) list; exp_type: type_expr; exp_env: Env.t } +and exp_extra = + | Texp_constraint of core_type option * core_type option + | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string + and expression_desc = - Texp_ident of Path.t * value_description + Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression - | Texp_function of (pattern * expression) list * partial - | Texp_apply of expression * (expression option * optional) list + | Texp_function of label * (pattern * expression) list * partial + | Texp_apply of expression * (label * expression option * optional) list | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list - | Texp_construct of constructor_description * expression list + | Texp_construct of + Path.t * Longident.t loc * constructor_description * expression list * + bool | Texp_variant of label * expression option - | Texp_record of (label_description * expression) list * expression option - | Texp_field of expression * label_description - | Texp_setfield of expression * label_description * expression + | Texp_record of + (Path.t * Longident.t loc * label_description * expression) list * + expression option + | Texp_field of expression * Path.t * Longident.t loc * label_description + | Texp_setfield of + expression * Path.t * Longident.t loc * label_description * expression | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of - Ident.t * expression * expression * direction_flag * expression + Ident.t * string loc * expression * expression * direction_flag * + expression | Texp_when of expression * expression - | Texp_send of expression * meth - | Texp_new of Path.t * class_declaration - | Texp_instvar of Path.t * Path.t - | Texp_setinstvar of Path.t * Path.t * expression - | Texp_override of Path.t * (Path.t * expression) list - | Texp_letmodule of Ident.t * module_expr * expression + | Texp_send of expression * meth * expression option + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Path.t * string loc * expression) list + | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_object of class_structure * class_signature * string list + | Texp_object of class_structure * string list | Texp_pack of module_expr (*> JOCAML *) | Texp_asyncsend of expression * expression @@ -155,65 +177,103 @@ and meth = and class_expr = { cl_desc: class_expr_desc; cl_loc: Location.t; - cl_type: class_type; + cl_type: Types.class_type; cl_env: Env.t } and class_expr_desc = - Tclass_ident of Path.t - | Tclass_structure of class_structure - | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial - | Tclass_apply of class_expr * (expression option * optional) list - | Tclass_let of rec_flag * (pattern * expression) list * - (Ident.t * expression) list * class_expr - | Tclass_constraint of class_expr * string list * string list * Concr.t + Tcl_ident of Path.t * Longident.t loc * core_type list (* Pcl_constr *) + | Tcl_structure of class_structure + | Tcl_fun of + label * pattern * (Ident.t * string loc * expression) list * class_expr * + partial + | Tcl_apply of class_expr * (label * expression option * optional) list + | Tcl_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list * Concr.t + (* Visible instance variables, methods and concretes methods *) and class_structure = - { cl_field: class_field list; - cl_meths: Ident.t Meths.t } + { cstr_pat : pattern; + cstr_fields: class_field list; + cstr_type : Types.class_signature; + cstr_meths: Ident.t Meths.t } 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_init of expression + { + cf_desc : class_field_desc; + cf_loc : Location.t; + } + +and class_field_kind = + Tcfk_virtual of core_type +| Tcfk_concrete of expression + +and class_field_desc = + Tcf_inher of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list + (* Inherited instance variables and concrete methods *) + | Tcf_val of + string * string loc * mutable_flag * Ident.t * class_field_kind * bool + (* None = virtual, true = override *) + | Tcf_meth of string * string loc * private_flag * class_field_kind * bool + | Tcf_constr of core_type * core_type +(* | Tcf_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list *) + | Tcf_init of expression (* Value expressions for the module language *) and module_expr = { mod_desc: module_expr_desc; mod_loc: Location.t; - mod_type: module_type; + mod_type: Types.module_type; mod_env: Env.t } +and module_type_constraint = + Tmodtype_implicit +| Tmodtype_explicit of module_type + and module_expr_desc = - Tmod_ident of Path.t + Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure - | Tmod_functor of Ident.t * module_type * module_expr + | Tmod_functor of Ident.t * string loc * module_type * module_expr | Tmod_apply of module_expr * module_expr * module_coercion - | Tmod_constraint of module_expr * module_type * module_coercion - | Tmod_unpack of expression * module_type + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type -and structure = structure_item list +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = Tstr_eval of expression | Tstr_value of rec_flag * (pattern * expression) list - | Tstr_primitive of Ident.t * value_description - | Tstr_type of (Ident.t * type_declaration) list - | Tstr_exception of Ident.t * exception_declaration - | Tstr_exn_rebind of Ident.t * Path.t - | Tstr_module of Ident.t * module_expr - | 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 * virtual_flag) list - | Tstr_cltype of (Ident.t * cltype_declaration) list + | Tstr_primitive of Ident.t * string loc * value_description + | Tstr_type of (Ident.t * string loc * type_declaration) list + | Tstr_exception of Ident.t * string loc * exception_declaration + | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc + | Tstr_module of Ident.t * string loc * module_expr + | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list + | Tstr_modtype of Ident.t * string loc * module_type + | Tstr_open of Path.t * Longident.t loc + | Tstr_class of (class_declaration * string list * virtual_flag) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list (*> JOCAML *) | Tstr_def of joinautomaton list | Tstr_loc of joinlocation list - | Tstr_exn_global of Location.t * Path.t + | Tstr_exn_global of Path.t * Longident.t loc (*< JOCAML *) and module_coercion = @@ -222,15 +282,181 @@ and module_coercion = | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; (* BINANNOT ADDED *) + mty_loc: Location.t } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of Ident.t * string loc * module_type * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of Ident.t * string loc * value_description + | Tsig_type of (Ident.t * string loc * type_declaration) list + | Tsig_exception of Ident.t * string loc * exception_declaration + | Tsig_module of Ident.t * string loc * module_type + | Tsig_recmodule of (Ident.t * string loc * module_type) list + | Tsig_modtype of Ident.t * string loc * modtype_declaration + | Tsig_open of Path.t * Longident.t loc + | Tsig_include of module_type * Types.signature + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + +and modtype_declaration = + Tmodtype_abstract + | Tmodtype_manifest of module_type + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + +and core_type = +(* mutable because of [Typeclass.declare_method] *) + { mutable ctyp_desc : core_type_desc; + mutable ctyp_type : type_expr; + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of core_field_type list + | Ttyp_class of Path.t * Longident.t loc * core_type list * label list + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * bool * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_name : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and core_field_type = + { field_desc: core_field_desc; + field_loc: Location.t } + +and core_field_desc = + Tcfield of string * core_type + | Tcfield_var + +and row_field = + Ttag of label * bool * core_type list + | Tinherit of core_type + +and value_description = + { val_desc : core_type; + val_val : Types.value_description; + val_prim : string list; + val_loc : Location.t; + } + +and type_declaration = + { typ_params: string loc option list; + typ_type : Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_variance: (bool * bool) list; + typ_loc: Location.t } + +and type_kind = + Ttype_abstract + | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list + | Ttype_record of + (Ident.t * string loc * mutable_flag * core_type * Location.t) list + +and exception_declaration = + { exn_params : core_type list; + exn_exn : Types.exception_declaration; + exn_loc : Location.t } + +and class_type = + { cltyp_desc: class_type_desc; + cltyp_type : Types.class_type; + cltyp_env : Env.t; (* BINANNOT ADDED *) + cltyp_loc: Location.t } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_fun of label * core_type * class_type + +and class_signature = { + csig_self : core_type; + csig_fields : class_type_field list; + csig_type : Types.class_signature; + csig_loc : Location.t; + } + +and class_type_field = { + ctf_desc : class_type_field_desc; + ctf_loc : Location.t; + } + +and class_type_field_desc = + Tctf_inher of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_virt of (string * private_flag * core_type) + | Tctf_meth of (string * private_flag * core_type) + | Tctf_cstr of (core_type * core_type) + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: string loc list * Location.t; + ci_id_name : string loc; + ci_id_class: Ident.t; + ci_id_class_type : Ident.t; + ci_id_object : Ident.t; + ci_id_typesharp : Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl : Types.class_type_declaration; + ci_variance: (bool * bool) list; + ci_loc: Location.t } + (* Auxiliary functions over the a.s.t. *) let iter_pattern_desc f = function - | Tpat_alias(p, id) -> f p + | Tpat_alias(p, _, _) -> f p | Tpat_tuple patl -> List.iter f patl - | Tpat_construct(cstr, patl) -> List.iter f patl + | Tpat_construct(_, _, cstr, patl, _) -> List.iter f patl | Tpat_variant(_, pat, _) -> may f pat - | Tpat_record lbl_pat_list -> - List.iter (fun (lbl, pat) -> f pat) lbl_pat_list + | Tpat_record (lbl_pat_list, _) -> + List.iter (fun (_, _, lbl, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or(p1, p2, _) -> f p1; f p2 | Tpat_lazy p -> f p @@ -240,14 +466,15 @@ let iter_pattern_desc f = function let map_pattern_desc f d = match d with - | Tpat_alias (p1, id) -> - Tpat_alias (f p1, id) + | Tpat_alias (p1, id, s) -> + Tpat_alias (f p1, id, s) | Tpat_tuple pats -> Tpat_tuple (List.map f pats) - | Tpat_record lpats -> - Tpat_record (List.map (fun (l,p) -> l, f p) lpats) - | Tpat_construct (c,pats) -> - Tpat_construct (c, List.map f pats) + | Tpat_record (lpats, closed) -> + Tpat_record (List.map (fun ( lid, lid_loc, l,p) -> lid, lid_loc, l, f p) + lpats, closed) + | Tpat_construct (lid, lid_loc, c,pats, arity) -> + Tpat_construct (lid, lid_loc, c, List.map f pats, arity) | Tpat_array pats -> Tpat_array (List.map f pats) | Tpat_lazy p1 -> Tpat_lazy (f p1) @@ -262,12 +489,13 @@ let map_pattern_desc f d = (* List the identifiers bound by a pattern or a let *) -let idents = ref([]: Ident.t list) +let idents = ref([]: (Ident.t * string loc) list) let rec bound_idents pat = match pat.pat_desc with - | Tpat_var id -> idents := id :: !idents - | Tpat_alias(p, id) -> bound_idents p; idents := id :: !idents + | Tpat_var (id,s) -> idents := (id,s) :: !idents + | Tpat_alias(p, id, s ) -> + bound_idents p; idents := (id,s) :: !idents | Tpat_or(p1, _, _) -> (* Invariant : both arguments binds the same variables *) bound_idents p1 @@ -276,13 +504,16 @@ let rec bound_idents pat = let pat_bound_idents pat = idents := []; bound_idents pat; let res = !idents in idents := []; res -let rev_let_bound_idents pat_expr_list = +let rev_let_bound_idents_with_loc pat_expr_list = idents := []; List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list; let res = !idents in idents := []; res -let let_bound_idents pat_expr_list = - List.rev(rev_let_bound_idents pat_expr_list) +let let_bound_idents_with_loc pat_expr_list = + List.rev(rev_let_bound_idents_with_loc pat_expr_list) + +let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat) +let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) (*> JOCAML *) let do_def_bound_idents autos r = @@ -307,16 +538,19 @@ let rev_loc_bound_idents d = List.rev (loc_bound_idents d) let alpha_var env id = List.assoc id env let rec alpha_pat env p = match p.pat_desc with -| Tpat_var id -> (* note the ``Not_found'' case *) +| Tpat_var (id, s) -> (* note the ``Not_found'' case *) {p with pat_desc = - try Tpat_var (alpha_var env id) with + try Tpat_var (alpha_var env id, s) with | Not_found -> Tpat_any} -| Tpat_alias (p1, id) -> +| Tpat_alias (p1, id, s) -> let new_p = alpha_pat env p1 in begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id)} + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} with | Not_found -> new_p end | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d} + +let mkloc = Location.mkloc +let mknoloc = Location.mknoloc diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 949774222d..5133377435 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -19,65 +19,87 @@ open Types (* Value expressions for the core language *) +type partial = Partial | Total +type optional = Required | Optional + type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; + pat_extra : (pat_extra * Location.t) list; pat_type: type_expr; mutable pat_env: Env.t } +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_unpack + and pattern_desc = Tpat_any - | Tpat_var of Ident.t - | Tpat_alias of pattern * Ident.t + | Tpat_var of Ident.t * string loc + | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list - | Tpat_construct of constructor_description * pattern list + | Tpat_construct of + Path.t * Longident.t loc * constructor_description * pattern list * bool | Tpat_variant of label * pattern option * row_desc ref - | Tpat_record of (label_description * pattern) list + | Tpat_record of + (Path.t * Longident.t loc * label_description * pattern) list * + closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern -type partial = Partial | Total -type optional = Required | Optional - -type expression = +and expression = { exp_desc: expression_desc; exp_loc: Location.t; + exp_extra : (exp_extra * Location.t) list; exp_type: type_expr; exp_env: Env.t } +and exp_extra = + | Texp_constraint of core_type option * core_type option + | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string + and expression_desc = - Texp_ident of Path.t * value_description + Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression - | Texp_function of (pattern * expression) list * partial - | Texp_apply of expression * (expression option * optional) list + | Texp_function of label * (pattern * expression) list * partial + | Texp_apply of expression * (label * expression option * optional) list | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list - | Texp_construct of constructor_description * expression list + | Texp_construct of + Path.t * Longident.t loc * constructor_description * expression list * + bool | Texp_variant of label * expression option - | Texp_record of (label_description * expression) list * expression option - | Texp_field of expression * label_description - | Texp_setfield of expression * label_description * expression + | Texp_record of + (Path.t * Longident.t loc * label_description * expression) list * + expression option + | Texp_field of expression * Path.t * Longident.t loc * label_description + | Texp_setfield of + expression * Path.t * Longident.t loc * label_description * expression | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of - Ident.t * expression * expression * direction_flag * expression + Ident.t * string loc * expression * expression * direction_flag * + expression | Texp_when of expression * expression - | Texp_send of expression * meth - | Texp_new of Path.t * class_declaration - | Texp_instvar of Path.t * Path.t - | Texp_setinstvar of Path.t * Path.t * expression - | Texp_override of Path.t * (Path.t * expression) list - | Texp_letmodule of Ident.t * module_expr * expression + | Texp_send of expression * meth * expression option + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Path.t * string loc * expression) list + | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_object of class_structure * class_signature * string list + | Texp_object of class_structure * string list | Texp_pack of module_expr (*> JOCAML *) | Texp_asyncsend of expression * expression @@ -148,68 +170,103 @@ and meth = and class_expr = { cl_desc: class_expr_desc; cl_loc: Location.t; - cl_type: class_type; + cl_type: Types.class_type; cl_env: Env.t } and class_expr_desc = - Tclass_ident of Path.t - | Tclass_structure of class_structure - | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial - | Tclass_apply of class_expr * (expression option * optional) list - | Tclass_let of rec_flag * (pattern * expression) list * - (Ident.t * expression) list * class_expr - | Tclass_constraint of class_expr * string list * string list * Concr.t + Tcl_ident of Path.t * Longident.t loc * core_type list + | Tcl_structure of class_structure + | Tcl_fun of + label * pattern * (Ident.t * string loc * expression) list * class_expr * + partial + | Tcl_apply of class_expr * (label * expression option * optional) list + | Tcl_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concretes methods *) and class_structure = - { cl_field: class_field list; - cl_meths: Ident.t Meths.t } + { cstr_pat : pattern; + cstr_fields: class_field list; + cstr_type : Types.class_signature; + cstr_meths: Ident.t Meths.t } and class_field = - Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list + { + cf_desc : class_field_desc; + cf_loc : Location.t; + } + +and class_field_kind = + Tcfk_virtual of core_type +| Tcfk_concrete of expression + +and class_field_desc = + Tcf_inher of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list (* Inherited instance variables and concrete methods *) - | Cf_val of string * Ident.t * expression option * bool + | Tcf_val of + string * string loc * mutable_flag * Ident.t * class_field_kind * bool (* None = virtual, true = override *) - | Cf_meth of string * expression - | Cf_init of expression + | Tcf_meth of string * string loc * private_flag * class_field_kind * bool + | Tcf_constr of core_type * core_type +(* | Tcf_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list *) + | Tcf_init of expression (* Value expressions for the module language *) and module_expr = { mod_desc: module_expr_desc; mod_loc: Location.t; - mod_type: module_type; + mod_type: Types.module_type; mod_env: Env.t } +and module_type_constraint = + Tmodtype_implicit +| Tmodtype_explicit of module_type + and module_expr_desc = - Tmod_ident of Path.t + Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure - | Tmod_functor of Ident.t * module_type * module_expr + | Tmod_functor of Ident.t * string loc * module_type * module_expr | Tmod_apply of module_expr * module_expr * module_coercion - | Tmod_constraint of module_expr * module_type * module_coercion - | Tmod_unpack of expression * module_type + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type -and structure = structure_item list +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = Tstr_eval of expression | Tstr_value of rec_flag * (pattern * expression) list - | Tstr_primitive of Ident.t * value_description - | Tstr_type of (Ident.t * type_declaration) list - | Tstr_exception of Ident.t * exception_declaration - | Tstr_exn_rebind of Ident.t * Path.t - | Tstr_module of Ident.t * module_expr - | 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 * virtual_flag) list - | Tstr_cltype of (Ident.t * cltype_declaration) list + | Tstr_primitive of Ident.t * string loc * value_description + | Tstr_type of (Ident.t * string loc * type_declaration) list + | Tstr_exception of Ident.t * string loc * exception_declaration + | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc + | Tstr_module of Ident.t * string loc * module_expr + | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list + | Tstr_modtype of Ident.t * string loc * module_type + | Tstr_open of Path.t * Longident.t loc + | Tstr_class of (class_declaration * string list * virtual_flag) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list (*> JOCAML *) | Tstr_def of joinautomaton list | Tstr_loc of joinlocation list - | Tstr_exn_global of Location.t * Path.t + | Tstr_exn_global of Path.t * Longident.t loc (*< JOCAML *) and module_coercion = @@ -218,10 +275,176 @@ and module_coercion = | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; + mty_loc: Location.t } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of Ident.t * string loc * module_type * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of Ident.t * string loc * value_description + | Tsig_type of (Ident.t * string loc * type_declaration) list + | Tsig_exception of Ident.t * string loc * exception_declaration + | Tsig_module of Ident.t * string loc * module_type + | Tsig_recmodule of (Ident.t * string loc * module_type) list + | Tsig_modtype of Ident.t * string loc * modtype_declaration + | Tsig_open of Path.t * Longident.t loc + | Tsig_include of module_type * Types.signature + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + +and modtype_declaration = + Tmodtype_abstract + | Tmodtype_manifest of module_type + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + +and core_type = +(* mutable because of [Typeclass.declare_method] *) + { mutable ctyp_desc : core_type_desc; + mutable ctyp_type : type_expr; + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of core_field_type list + | Ttyp_class of Path.t * Longident.t loc * core_type list * label list + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * bool * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_name : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and core_field_type = + { field_desc: core_field_desc; + field_loc: Location.t } + +and core_field_desc = + Tcfield of string * core_type + | Tcfield_var + +and row_field = + Ttag of label * bool * core_type list + | Tinherit of core_type + +and value_description = + { val_desc : core_type; + val_val : Types.value_description; + val_prim : string list; + val_loc : Location.t; + } + +and type_declaration = + { typ_params: string loc option list; + typ_type : Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_variance: (bool * bool) list; + typ_loc: Location.t } + +and type_kind = + Ttype_abstract + | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list + | Ttype_record of + (Ident.t * string loc * mutable_flag * core_type * Location.t) list + +and exception_declaration = + { exn_params : core_type list; + exn_exn : Types.exception_declaration; + exn_loc : Location.t } + +and class_type = + { cltyp_desc: class_type_desc; + cltyp_type : Types.class_type; + cltyp_env : Env.t; (* BINANNOT ADDED *) + cltyp_loc: Location.t } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_fun of label * core_type * class_type + +and class_signature = { + csig_self : core_type; + csig_fields : class_type_field list; + csig_type : Types.class_signature; + csig_loc : Location.t; + } + +and class_type_field = { + ctf_desc : class_type_field_desc; + ctf_loc : Location.t; + } + +and class_type_field_desc = + Tctf_inher of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_virt of (string * private_flag * core_type) + | Tctf_meth of (string * private_flag * core_type) + | Tctf_cstr of (core_type * core_type) + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: string loc list * Location.t; + ci_id_name : string loc; + ci_id_class: Ident.t; + ci_id_class_type : Ident.t; + ci_id_object : Ident.t; + ci_id_typesharp : Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl : Types.class_type_declaration; + ci_variance: (bool * bool) list; + ci_loc: Location.t } + (* Auxiliary functions over the a.s.t. *) -val iter_pattern_desc : (pattern -> unit) -> pattern_desc -> unit -val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc +val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit +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 @@ -233,5 +456,15 @@ val rev_def_bound_idents: joinautomaton list -> Ident.t list val rev_loc_bound_idents: joinlocation list -> Ident.t list (*< JOCAML *) +val let_bound_idents_with_loc: + (pattern * expression) list -> (Ident.t * string loc) list +val rev_let_bound_idents_with_loc: + (pattern * expression) list -> (Ident.t * string loc) list + (* Alpha conversion of patterns *) -val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern +val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern + +val mknoloc: 'a -> 'a Asttypes.loc +val mkloc: 'a -> Location.t -> 'a Asttypes.loc + +val pat_bound_idents: pattern -> (Ident.t * string Asttypes.loc) list diff --git a/typing/typemod.ml b/typing/typemod.ml index 2f5fab2520..669bd0f34b 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -12,15 +12,12 @@ (* $Id$ *) -(* Type-checking of the module language *) - open Misc open Longident open Path open Asttypes open Parsetree open Types -open Typedtree open Format type error = @@ -45,24 +42,34 @@ type error = exception Error of Location.t * error +open Typedtree + +let fst3 (x,_,_) = x + +let rec path_concat head p = + match p with + Pident tail -> Pdot (Pident head, Ident.name tail, 0) + | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) + | Papply _ -> assert false + (* Extract a signature from a module type *) let extract_sig env loc mty = match Mtype.scrape env mty with - Tmty_signature sg -> sg + Mty_signature sg -> sg | _ -> raise(Error(loc, Signature_expected)) let extract_sig_open env loc mty = match Mtype.scrape env mty with - Tmty_signature sg -> sg + Mty_signature sg -> sg | _ -> raise(Error(loc, Structure_expected mty)) (* Compute the environment after opening a module *) -let type_open env loc lid = - let (path, mty) = Typetexp.find_module env loc lid in +let type_open ?toplevel env loc lid = + let (path, mty) = Typetexp.find_module env loc lid.txt in let sg = extract_sig_open env loc mty in - Env.open_signature ~loc path sg env + path, Env.open_signature ~loc ?toplevel path sg env (* Record a module type *) let rm node = @@ -70,14 +77,15 @@ let rm node = node (* Forward declaration, to be filled in by type_module_type_of *) -let type_module_type_of_fwd - : (Env.t -> Parsetree.module_expr -> module_type) ref +let type_module_type_of_fwd : + (Env.t -> Parsetree.module_expr -> + Typedtree.module_expr * Types.module_type) ref = ref (fun env m -> assert false) (* Merge one "with" constraint in a signature *) let rec add_rec_types env = function - Tsig_type(id, decl, Trec_next) :: rem -> + Sig_type(id, decl, Trec_next) :: rem -> add_rec_types (Env.add_type id decl env) rem | _ -> env @@ -97,20 +105,24 @@ let wrap_param s = {ptyp_desc=Ptyp_var s; ptyp_loc=Location.none} let make_next_first rs rem = if rs = Trec_first then match rem with - Tsig_type (id, decl, Trec_next) :: rem -> - Tsig_type (id, decl, Trec_first) :: rem - | Tsig_module (id, mty, Trec_next) :: rem -> - Tsig_module (id, mty, Trec_first) :: rem + Sig_type (id, decl, Trec_next) :: rem -> + Sig_type (id, decl, Trec_first) :: rem + | Sig_module (id, mty, Trec_next) :: rem -> + Sig_module (id, mty, Trec_first) :: rem | _ -> rem else rem -let merge_constraint initial_env loc sg lid constr = +let sig_item desc typ env loc = { + Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env +} + +let merge_constraint initial_env loc sg lid constr = let real_id = ref None in let rec merge env sg namelist row_id = match (sg, namelist, constr) with ([], _, _) -> - raise(Error(loc, With_no_component lid)) - | (Tsig_type(id, decl, rs) :: rem, [s], + raise(Error(loc, With_no_component lid.txt)) + | (Sig_type(id, decl, rs) :: rem, [s], Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = @@ -127,83 +139,102 @@ let merge_constraint initial_env loc sg lid constr = 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 + let tdecl = Typedecl.transl_with_constraint initial_env id (Some(Pident id_row)) decl sdecl in + let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; let decl_row = {decl_row with type_params = newdecl.type_params} in let rs' = if rs = Trec_first then Trec_not else rs in - Tsig_type(id_row, decl_row, rs') :: Tsig_type(id, newdecl, rs) :: rem - | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl) + (Pident id, lid, Twith_type tdecl), + Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem + | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type sdecl) when Ident.name id = s -> - let newdecl = + let tdecl = Typedecl.transl_with_constraint initial_env id None decl sdecl in + let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; - Tsig_type(id, newdecl, rs) :: rem - | (Tsig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) + (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem + | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) when Ident.name id = s ^ "#row" -> merge env rem namelist (Some id) - | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl) + | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl) when Ident.name id = s -> (* Check as for a normal with constraint, but discard definition *) - let newdecl = + let tdecl = Typedecl.transl_with_constraint initial_env id None decl sdecl in + let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; real_id := Some id; + (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem - | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid) + | (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (lid)) when Ident.name id = s -> - let (path, mty') = Typetexp.find_module initial_env loc lid in + let (path, mty') = Typetexp.find_module initial_env loc lid.txt in let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); - Tsig_module(id, newmty, rs) :: rem - | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_modsubst lid) + (Pident id, lid, Twith_module (path, lid)), + Sig_module(id, newmty, rs) :: rem + | (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (lid)) when Ident.name id = s -> - let (path, mty') = Typetexp.find_module initial_env loc lid in + let (path, mty') = Typetexp.find_module initial_env loc lid.txt in let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); real_id := Some id; + (Pident id, lid, Twith_modsubst (path, lid)), make_next_first rs rem - | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _) + | (Sig_module(id, mty, rs) :: rem, s :: namelist, _) when Ident.name id = s -> - let newsg = merge env (extract_sig env loc mty) namelist None in - Tsig_module(id, Tmty_signature newsg, rs) :: rem + let ((path, path_loc, tcstr), newsg) = + merge env (extract_sig env loc mty) namelist None in + (path_concat id path, lid, tcstr), + Sig_module(id, Mty_signature newsg, rs) :: rem | (item :: rem, _, _) -> - item :: merge (Env.add_item item env) rem namelist row_id in + let (cstr, items) = merge (Env.add_item item env) rem namelist row_id + in + cstr, item :: items + in try - let names = Longident.flatten lid in - let sg = merge initial_env sg names None in + let names = Longident.flatten lid.txt in + let (tcstr, sg) = merge initial_env sg names None in + let sg = match names, constr with [s], Pwith_typesubst sdecl -> let id = match !real_id with None -> assert false | Some id -> id in let lid = try match sdecl.ptype_manifest with - | Some {ptyp_desc = Ptyp_constr (lid, stl)} -> + | Some {ptyp_desc = Ptyp_constr (lid, stl)} + when List.length stl = List.length sdecl.ptype_params -> let params = List.map (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit) stl in - if List.map (fun x -> Some x) params <> sdecl.ptype_params - then raise Exit; + List.iter2 (fun x ox -> + match ox with + Some y when x = y.txt -> () + | _ -> raise Exit + ) params sdecl.ptype_params; lid | _ -> raise Exit with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr)) in let (path, _) = - try Env.lookup_type lid initial_env with Not_found -> assert false + try Env.lookup_type lid.txt initial_env with Not_found -> assert false in let sub = Subst.add_type id path Subst.identity in Subst.signature sub sg - | [s], Pwith_modsubst lid -> + | [s], Pwith_modsubst (lid) -> let id = match !real_id with None -> assert false | Some id -> id in - let (path, _) = Typetexp.find_module initial_env loc lid in + let (path, _) = Typetexp.find_module initial_env loc lid.txt in let sub = Subst.add_module id path Subst.identity in Subst.signature sub sg | _ -> - sg + sg + in + (tcstr, sg) with Includemod.Error explanation -> - raise(Error(loc, With_mismatch(lid, explanation))) + raise(Error(loc, With_mismatch(lid.txt, explanation))) (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -219,6 +250,12 @@ let rec map_rec' fn decls rem = fn Trec_not d1 :: map_rec' fn dl rem | _ -> map_rec fn decls rem +let rec map_rec'' fn decls rem = + match decls with + | (id, _,_ as d1) :: dl when Btype.is_row_name (Ident.name id) -> + fn Trec_not d1 :: map_rec'' fn dl rem + | _ -> map_rec fn decls rem + (* Auxiliary for translating recursively-defined module types. Return a module type that approximates the shape of the given module type AST. Retain only module, type, and module type @@ -228,19 +265,20 @@ let rec map_rec' fn decls rem = let rec approx_modtype env smty = match smty.pmty_desc with Pmty_ident lid -> - let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid in - Tmty_ident path + let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in + Mty_ident path | Pmty_signature ssg -> - Tmty_signature(approx_sig env ssg) + Mty_signature(approx_sig env ssg) | Pmty_functor(param, sarg, sres) -> let arg = approx_modtype env sarg in - let (id, newenv) = Env.enter_module param arg env in + let (id, newenv) = Env.enter_module param.txt arg env in let res = approx_modtype newenv sres in - Tmty_functor(id, arg, res) + Mty_functor(id, arg, res) | Pmty_with(sbody, constraints) -> approx_modtype env sbody | Pmty_typeof smod -> - !type_module_type_of_fwd env smod + let (_, mty) = !type_module_type_of_fwd env smod in + mty and approx_sig env ssg = match ssg with @@ -250,28 +288,29 @@ and approx_sig env ssg = | Psig_type sdecls -> let decls = Typedecl.approx_type_decl env sdecls in let rem = approx_sig env srem in - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem + map_rec' (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem | Psig_module(name, smty) -> let mty = approx_modtype env smty in - let (id, newenv) = Env.enter_module name mty env in - Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem + let (id, newenv) = Env.enter_module name.txt mty env in + Sig_module(id, mty, Trec_not) :: approx_sig newenv srem | Psig_recmodule sdecls -> let decls = List.map (fun (name, smty) -> - (Ident.create name, approx_modtype env smty)) + (Ident.create name.txt, approx_modtype env smty)) sdecls in let newenv = List.fold_left (fun env (id, mty) -> Env.add_module id mty env) env decls in - map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls + map_rec (fun rs (id, mty) -> Sig_module(id, mty, rs)) decls (approx_sig newenv srem) | Psig_modtype(name, sinfo) -> let info = approx_modtype_info env sinfo in - let (id, newenv) = Env.enter_modtype name info env in - Tsig_modtype(id, info) :: approx_sig newenv srem + let (id, newenv) = Env.enter_modtype name.txt info env in + Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open lid -> - approx_sig (type_open env item.psig_loc lid) srem + let (path, mty) = type_open env item.psig_loc lid in + approx_sig mty srem | Psig_include smty -> let mty = approx_modtype env smty in let sg = Subst.signature Subst.identity @@ -283,10 +322,10 @@ and approx_sig env ssg = let rem = approx_sig env srem in List.flatten (map_rec - (fun rs (i1, d1, i2, d2, i3, d3) -> - [Tsig_cltype(i1, d1, rs); - Tsig_type(i2, d2, rs); - Tsig_type(i3, d3, rs)]) + (fun rs (i1, _, d1, i2, d2, i3, d3, _) -> + [Sig_class_type(i1, d1, rs); + Sig_type(i2, d2, rs); + Sig_type(i3, d3, rs)]) decls [rem]) | _ -> approx_sig env srem @@ -294,17 +333,18 @@ and approx_sig env ssg = and approx_modtype_info env sinfo = match sinfo with Pmodtype_abstract -> - Tmodtype_abstract + Modtype_abstract | Pmodtype_manifest smty -> - Tmodtype_manifest(approx_modtype env smty) + Modtype_manifest(approx_modtype env smty) (* Additional validity checks on type definitions arising from recursive modules *) let check_recmod_typedecls env sdecls decls = - let recmod_ids = List.map fst decls in + let recmod_ids = List.map fst3 decls in List.iter2 - (fun (_, smty) (id, mty) -> + (fun (_, smty) (id, _, mty) -> + let mty = mty.mty_type in List.iter (fun path -> Typedecl.check_recmod_typedecl env smty.pmty_loc recmod_ids @@ -322,23 +362,23 @@ let check cl loc set_ref name = else set_ref := StringSet.add name !set_ref let check_sig_item type_names module_names modtype_names loc = function - Tsig_type(id, _, _) -> + Sig_type(id, _, _) -> check "type" loc type_names (Ident.name id) - | Tsig_module(id, _, _) -> + | Sig_module(id, _, _) -> check "module" loc module_names (Ident.name id) - | Tsig_modtype(id, _) -> + | Sig_modtype(id, _) -> check "module type" loc modtype_names (Ident.name id) | _ -> () let rec remove_values ids = function [] -> [] - | Tsig_value (id, _) :: rem + | Sig_value (id, _) :: rem when List.exists (Ident.equal id) ids -> remove_values ids rem | f :: rem -> f :: remove_values ids rem let rec get_values = function [] -> [] - | Tsig_value (id, _) :: rem -> id :: get_values rem + | Sig_value (id, _) :: rem -> id :: get_values rem | f :: rem -> get_values rem (* Check and translate a module type expression *) @@ -347,28 +387,55 @@ let transl_modtype_longident loc env lid = let (path, info) = Typetexp.find_modtype env loc lid in path +let mkmty desc typ env loc = + let mty = { + mty_desc = desc; + mty_type = typ; + mty_loc = loc; + mty_env = env; + } in + Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); + mty + +let mksig desc env loc = + let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); + sg + +(* let signature sg = List.map (fun item -> item.sig_type) sg *) + let rec transl_modtype env smty = + let loc = smty.pmty_loc in match smty.pmty_desc with Pmty_ident lid -> - Tmty_ident (transl_modtype_longident smty.pmty_loc env lid) + let path = transl_modtype_longident loc env lid.txt in + mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc | Pmty_signature ssg -> - Tmty_signature(transl_signature env ssg) + let sg = transl_signature env ssg in + mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc | Pmty_functor(param, sarg, sres) -> let arg = transl_modtype env sarg in - let (id, newenv) = Env.enter_module param arg env in + let (id, newenv) = Env.enter_module param.txt arg.mty_type env in let res = transl_modtype newenv sres in - Tmty_functor(id, arg, res) + mkmty (Tmty_functor (id, param, arg, res)) + (Mty_functor(id, arg.mty_type, res.mty_type)) env loc | Pmty_with(sbody, constraints) -> let body = transl_modtype env sbody in - let init_sg = extract_sig env sbody.pmty_loc body in - let final_sg = + let init_sg = extract_sig env sbody.pmty_loc body.mty_type in + let (tcstrs, final_sg) = List.fold_left - (fun sg (lid, sdecl) -> - merge_constraint env smty.pmty_loc sg lid sdecl) - init_sg constraints in - Mtype.freshen (Tmty_signature final_sg) + (fun (tcstrs,sg) (lid, sdecl) -> + let (tcstr, sg) = merge_constraint env smty.pmty_loc sg lid sdecl + in + (tcstr :: tcstrs, sg) + ) + ([],init_sg) constraints in + mkmty (Tmty_with ( body, tcstrs)) + (Mtype.freshen (Mty_signature final_sg)) env loc | Pmty_typeof smod -> - !type_module_type_of_fwd env smod + let tmty, mty = !type_module_type_of_fwd env smod in + mkmty (Tmty_typeof tmty) mty env loc + and transl_signature env sg = let type_names = ref StringSet.empty @@ -377,52 +444,75 @@ and transl_signature env sg = let rec transl_sig env sg = Ctype.init_def(Ident.current_time()); match sg with - [] -> [] + [] -> [], [], env | item :: srem -> + let loc = item.psig_loc in match item.psig_desc with | Psig_value(name, sdesc) -> - 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 + let tdesc = Typedecl.transl_value_decl env item.psig_loc sdesc in + let desc = tdesc.val_val in + let (id, newenv) = + Env.enter_value name.txt desc env + ~check:(fun s -> Warnings.Unused_value_declaration s) in + let (trem,rem, final_env) = transl_sig newenv srem in + mksig (Tsig_value (id, name, tdesc)) env loc :: trem, + (if List.exists (Ident.equal id) (get_values rem) then rem + else Sig_value(id, desc) :: rem), + final_env | Psig_type sdecls -> List.iter - (fun (name, decl) -> check "type" item.psig_loc type_names name) + (fun (name, decl) -> + check "type" item.psig_loc type_names name.txt) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in - let rem = transl_sig newenv srem in - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_type decls) env loc :: trem, + map_rec'' (fun rs (id, _, info) -> + Sig_type(id, info.typ_type, rs)) decls rem, + final_env | Psig_exception(name, sarg) -> 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 + let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_exception (id, name, arg)) env loc :: trem, + Sig_exception(id, arg.exn_exn) :: rem, + final_env | Psig_module(name, smty) -> - check "module" item.psig_loc module_names name; - let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_module name mty env in - let rem = transl_sig newenv srem in - Tsig_module(id, mty, Trec_not) :: rem + check "module" item.psig_loc module_names name.txt; + let tmty = transl_modtype env smty in + let mty = tmty.mty_type in + let (id, newenv) = Env.enter_module name.txt mty env in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_module (id, name, tmty)) env loc :: trem, + Sig_module(id, mty, Trec_not) :: rem, + final_env | Psig_recmodule sdecls -> List.iter (fun (name, smty) -> - check "module" item.psig_loc module_names name) + check "module" item.psig_loc module_names name.txt) sdecls; let (decls, newenv) = transl_recmodule_modtypes item.psig_loc env sdecls in - let rem = transl_sig newenv srem in - map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls rem + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_recmodule decls) env loc :: trem, + map_rec (fun rs (id, _, tmty) -> Sig_module(id, tmty.mty_type, rs)) + decls rem, + final_env | Psig_modtype(name, sinfo) -> - check "module type" item.psig_loc modtype_names name; - let info = transl_modtype_info env sinfo in - let (id, newenv) = Env.enter_modtype name info env in - let rem = transl_sig newenv srem in - Tsig_modtype(id, info) :: rem + check "module type" item.psig_loc modtype_names name.txt; + let (tinfo, info) = transl_modtype_info env sinfo in + let (id, newenv) = Env.enter_modtype name.txt info env in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem, + Sig_modtype(id, info) :: rem, + final_env | Psig_open lid -> - transl_sig (type_open env item.psig_loc lid) srem + let (path, newenv) = type_open env item.psig_loc lid in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env | Psig_include smty -> - let mty = transl_modtype env smty in + let tmty = transl_modtype env smty in + let mty = tmty.mty_type in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in List.iter @@ -430,63 +520,88 @@ and transl_signature env sg = item.psig_loc) sg; let newenv = Env.add_signature sg env in - let rem = transl_sig newenv srem in - remove_values (get_values rem) sg @ rem + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_include (tmty, sg)) env loc :: trem, + remove_values (get_values rem) sg @ rem, final_env | Psig_class cl -> List.iter (fun {pci_name = name} -> - check "type" item.psig_loc type_names name) + check "type" item.psig_loc type_names name.txt ) cl; let (classes, newenv) = Typeclass.class_descriptions env cl in - let rem = transl_sig newenv srem in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_class + (List.map2 + (fun pcl tcl -> + let (_, _, _, _, _, _, _, _, _, _, _, tcl) = tcl in + tcl) + cl classes)) env loc + :: trem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) -> - [Tsig_class(i, d, rs); - Tsig_cltype(i', d', rs); - Tsig_type(i'', d'', rs); - Tsig_type(i''', d''', rs)]) - classes [rem]) + (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) -> + [Sig_class(i, d, rs); + Sig_class_type(i', d', rs); + Sig_type(i'', d'', rs); + Sig_type(i''', d''', rs)]) + classes [rem]), + final_env | Psig_class_type cl -> List.iter (fun {pci_name = name} -> - check "type" item.psig_loc type_names name) + check "type" item.psig_loc type_names name.txt) cl; let (classes, newenv) = Typeclass.class_type_declarations env cl in - let rem = transl_sig newenv srem in + let (trem,rem, final_env) = transl_sig newenv srem in + mksig (Tsig_class_type (List.map2 (fun pcl tcl -> + let (_, _, _, _, _, _, _, tcl) = tcl in + tcl + ) cl classes)) env loc :: trem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'') -> - [Tsig_cltype(i, d, rs); - Tsig_type(i', d', rs); - Tsig_type(i'', d'', rs)]) - classes [rem]) - in transl_sig env sg + (fun rs (i, _, d, i', d', i'', d'', _) -> + [Sig_class_type(i, d, rs); + Sig_type(i', d', rs); + Sig_type(i'', d'', rs)]) + classes [rem]), + final_env + in + let previous_saved_types = Cmt_format.get_saved_types () in + let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in + let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in + Cmt_format.set_saved_types + ((Cmt_format.Partial_signature sg) :: previous_saved_types); + sg and transl_modtype_info env sinfo = match sinfo with Pmodtype_abstract -> - Tmodtype_abstract + Tmodtype_abstract, Modtype_abstract | Pmodtype_manifest smty -> - Tmodtype_manifest(transl_modtype env smty) + let tmty = transl_modtype env smty in + Tmodtype_manifest tmty, Modtype_manifest tmty.mty_type and transl_recmodule_modtypes loc env sdecls = let make_env curr = List.fold_left - (fun env (id, mty) -> Env.add_module id mty env) + (fun env (id, _, mty) -> Env.add_module id mty env) + env curr in + let make_env2 curr = + List.fold_left + (fun env (id, _, mty) -> Env.add_module id mty.mty_type env) env curr in let transition env_c curr = List.map2 - (fun (_, smty) (id, mty) -> (id, transl_modtype env_c smty)) + (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty)) sdecls curr in let init = List.map (fun (name, smty) -> - (Ident.create name, approx_modtype env smty)) + (Ident.create name.txt, name, approx_modtype env smty)) sdecls in let env0 = make_env init in let dcl1 = transition env0 init in - let env1 = make_env dcl1 in + let env1 = make_env2 dcl1 in check_recmod_typedecls env1 sdecls dcl1; let dcl2 = transition env1 dcl1 in (* @@ -495,7 +610,7 @@ and transl_recmodule_modtypes loc env sdecls = Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) dcl2; *) - let env2 = make_env dcl2 in + let env2 = make_env2 dcl2 in check_recmod_typedecls env2 sdecls dcl2; (dcl2, env2) @@ -505,7 +620,7 @@ exception Not_a_path let rec path_of_module mexp = match mexp.mod_desc with - Tmod_ident p -> p + Tmod_ident (p,_) -> p | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors -> Papply(path_of_module funct, path_of_module arg) | _ -> raise Not_a_path @@ -513,23 +628,24 @@ let rec path_of_module mexp = (* Check that all core type schemes in a structure are closed *) let rec closed_modtype = function - Tmty_ident p -> true - | Tmty_signature sg -> List.for_all closed_signature_item sg - | Tmty_functor(id, param, body) -> closed_modtype body + Mty_ident p -> true + | Mty_signature sg -> List.for_all closed_signature_item sg + | Mty_functor(id, param, body) -> closed_modtype body and closed_signature_item = function - Tsig_value(id, desc) -> Ctype.closed_schema desc.val_type - | Tsig_module(id, mty, _) -> closed_modtype mty + Sig_value(id, desc) -> Ctype.closed_schema desc.val_type + | Sig_module(id, mty, _) -> closed_modtype mty | _ -> true -let check_nongen_scheme env = function +let check_nongen_scheme env str = + match str.str_desc with Tstr_value(rec_flag, pat_exp_list) -> List.iter (fun (pat, exp) -> if not (Ctype.closed_schema exp.exp_type) then raise(Error(exp.exp_loc, Non_generalizable exp.exp_type))) pat_exp_list - | Tstr_module(id, md) -> + | Tstr_module(id, _, md) -> if not (closed_modtype md.mod_type) then raise(Error(md.mod_loc, Non_generalizable_module md.mod_type)) | _ -> () @@ -544,21 +660,19 @@ let check_nongen_schemes env str = let rec bound_value_identifiers = function [] -> [] - | Tsig_value(id, {val_kind = Val_reg}) :: rem -> + | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem - | Tsig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem - | Tsig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem -(* Type a module value expression *) - (*> JOCAML *) (* Channels appear as regular values in signatures *) let make_sig_channel_value env id = try let desc = Env.find_value (Pident id) env in - Tsig_value(id, {desc with val_kind=Val_reg}) + Sig_value(id, {desc with val_kind=Val_reg}) with Not_found -> assert false (*< JOCAML *) @@ -574,9 +688,10 @@ let enrich_type_decls anchor decls oldenv newenv = None -> newenv | Some p -> List.fold_left - (fun e (id, info) -> + (fun e (id, _, info) -> let info' = - Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) info + Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) + info.typ_type in Env.add_type id info' e) oldenv decls @@ -616,7 +731,7 @@ let check_recmodule_inclusion env bindings = (* Generate fresh names Y_i for the rec. bound module idents X_i *) let bindings1 = List.map - (fun (id, mty_decl, modl, mty_actual) -> + (fun (id, _, mty_decl, modl, mty_actual) -> (id, Ident.rename id, mty_actual)) bindings in (* Enter the Y_i in the environment with their actual types substituted @@ -641,8 +756,8 @@ let check_recmodule_inclusion env bindings = end else begin (* Base case: check inclusion of s(mty_actual) in s(mty_decl) and insert coercion if needed *) - let check_inclusion (id, mty_decl, modl, mty_actual) = - let mty_decl' = Subst.modtype s mty_decl + let check_inclusion (id, id_loc, mty_decl, modl, mty_actual) = + let mty_decl' = Subst.modtype s mty_decl.mty_type and mty_actual' = subst_and_strengthen env s id mty_actual in let coercion = try @@ -650,11 +765,12 @@ let check_recmodule_inclusion env bindings = with Includemod.Error msg -> raise(Error(modl.mod_loc, Not_included msg)) in let modl' = - { mod_desc = Tmod_constraint(modl, mty_decl, coercion); - mod_type = mty_decl; + { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, + Tmodtype_explicit mty_decl, coercion); + mod_type = mty_decl.mty_type; mod_env = env; mod_loc = modl.mod_loc } in - (id, modl') in + (id, id_loc, mty_decl, modl') in List.map check_inclusion bindings end in check_incl true (List.length bindings) env Subst.identity @@ -667,50 +783,58 @@ let rec package_constraints env loc mty constrs = let sg' = List.map (function - | Tsig_type (id, ({type_params=[]} as td), rs) when List.mem_assoc [Ident.name id] constrs -> + | Sig_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) -> + Sig_type (id, {td with type_manifest = Some ty}, rs) + | Sig_module (id, mty, rs) -> let rec aux = function - | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest + | (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) + Sig_module (id, package_constraints env loc mty (aux constrs), rs) | item -> item ) sg in - Tmty_signature sg' + Mty_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) + | Modtype_manifest mty when nl <> [] -> + package_constraints env loc mty + (List.combine (List.map Longident.flatten nl) tl) | _ -> - if nl = [] then Tmty_ident p + if nl = [] then Mty_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 wrap_constraint env arg mty explicit = let coercion = try Includemod.modtypes env arg.mod_type mty with Includemod.Error msg -> raise(Error(arg.mod_loc, Not_included msg)) in - { mod_desc = Tmod_constraint(arg, mty, coercion); + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); mod_type = mty; mod_env = env; mod_loc = arg.mod_loc } (* Type a module value expression *) +let mkstr desc loc env = + let str = { str_desc = desc; str_loc = loc; str_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str); + str + let rec type_module sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let (path, mty) = Typetexp.find_module env smod.pmod_loc lid in - rm { mod_desc = Tmod_ident path; + let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in + rm { mod_desc = Tmod_ident (path, lid); mod_type = if sttn then Mtype.strengthen env mty path else mty; mod_env = env; mod_loc = smod.pmod_loc } @@ -718,15 +842,15 @@ let rec type_module sttn funct_body anchor env smod = let (str, sg, finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in rm { mod_desc = Tmod_structure str; - mod_type = Tmty_signature sg; + mod_type = Mty_signature sg; mod_env = env; mod_loc = smod.pmod_loc } | Pmod_functor(name, smty, sbody) -> let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_module name mty env in + let (id, newenv) = Env.enter_module name.txt mty.mty_type env in let body = type_module sttn true None newenv sbody in - rm { mod_desc = Tmod_functor(id, mty, body); - mod_type = Tmty_functor(id, mty, body.mod_type); + rm { mod_desc = Tmod_functor(id, name, mty, body); + mod_type = Mty_functor(id, mty.mty_type, body.mod_type); mod_env = env; mod_loc = smod.pmod_loc } | Pmod_apply(sfunct, sarg) -> @@ -735,7 +859,7 @@ let rec type_module sttn funct_body anchor env smod = let funct = type_module (sttn && path <> None) funct_body None env sfunct in begin match Mtype.scrape env funct.mod_type with - Tmty_functor(param, mty_param, mty_res) as mty_functor -> + Mty_functor(param, mty_param, mty_res) as mty_functor -> let coercion = try Includemod.modtypes env arg.mod_type mty_param @@ -764,7 +888,8 @@ 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 - rm {(wrap_constraint env arg mty) with mod_loc = smod.pmod_loc} + rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with + mod_loc = smod.pmod_loc} | Pmod_unpack sexp -> if funct_body then @@ -798,20 +923,24 @@ let rec type_module sttn funct_body anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } -and type_structure funct_body anchor env sstr scope = +and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in let rec type_struct env sstr = + let mkstr desc loc = mkstr desc loc env in Ctype.init_def(Ident.current_time()); match sstr with [] -> ([], [], env) - | {pstr_desc = Pstr_eval sexpr} :: srem -> - let expr = Typecore.type_expression env sexpr in - let (str_rem, sig_rem, final_env) = type_struct env srem in - (Tstr_eval expr :: str_rem, sig_rem, final_env) - | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem -> + | pstr :: srem -> + let loc = pstr.pstr_loc in + match pstr.pstr_desc with + | Pstr_eval sexpr -> + let expr = Typecore.type_expression env sexpr in + let (str_rem, sig_rem, final_env) = type_struct env srem in + (mkstr (Tstr_eval expr) loc :: str_rem, sig_rem, final_env) + | Pstr_value(rec_flag, sdefs) -> let scope = match rec_flag with | Recursive -> Some (Annot.Idef {scope with @@ -830,157 +959,145 @@ and type_structure funct_body anchor env sstr scope = (* 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, + Sig_value(id, Env.find_value (Pident id) newenv) in + (mkstr (Tstr_value(rec_flag, defs)) loc :: str_rem, map_end make_sig_value bound_idents sig_rem, final_env) -(*> JOCAML *) - | {pstr_desc = Pstr_def (sdefs) ; pstr_loc = loc} :: srem -> - let scope = - let start = match srem with - | [] -> loc.Location.loc_end - | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in - Some (Annot.Idef {scope with Location.loc_start = start}) in - let (defs, newenv) = - Typecore.type_joindefinition env sdefs scope in - let (str_rem, sig_rem, final_env) = type_struct newenv srem in - let bound_idents = Typedtree.def_bound_idents defs in - (Tstr_def (defs) :: str_rem, - map_end (make_sig_channel_value newenv) bound_idents sig_rem, - final_env) - | {pstr_desc = Pstr_exn_global(longid); pstr_loc = loc} :: srem -> - let path = Typedecl.transl_exn_global env loc longid in - let (str_rem, sig_rem, final_env) = type_struct env srem in - (Tstr_exn_global (loc,path) :: str_rem, - sig_rem, - final_env) -(*< JOCAML *) - | {pstr_desc = Pstr_primitive(name, sdesc); pstr_loc = loc} :: srem -> + | Pstr_primitive(name, sdesc) -> 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 (id, newenv) = Env.enter_value name.txt desc.val_val env + ~check:(fun s -> Warnings.Unused_value_declaration s) 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, + (mkstr (Tstr_primitive(id, name, desc)) loc :: str_rem, + Sig_value(id, desc.val_val) :: sig_rem, final_env) - | {pstr_desc = Pstr_type sdecls; pstr_loc = loc} :: srem -> + | Pstr_type sdecls -> List.iter - (fun (name, decl) -> check "type" loc type_names name) + (fun (name, decl) -> check "type" loc type_names name.txt) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in let newenv' = enrich_type_decls anchor decls env newenv in let (str_rem, sig_rem, final_env) = type_struct newenv' srem in - (Tstr_type decls :: str_rem, - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem, + (mkstr (Tstr_type decls) loc :: str_rem, + map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs)) + decls sig_rem, final_env) - | {pstr_desc = Pstr_exception(name, sarg); pstr_loc = loc} :: srem -> + | Pstr_exception(name, sarg) -> let arg = Typedecl.transl_exception env loc sarg in - let (id, newenv) = Env.enter_exception name arg env in + let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_exception(id, arg) :: str_rem, - Tsig_exception(id, arg) :: sig_rem, + (mkstr (Tstr_exception(id, name, arg)) loc :: str_rem, + Sig_exception(id, arg.exn_exn) :: sig_rem, final_env) - | {pstr_desc = Pstr_exn_rebind(name, longid); pstr_loc = loc} :: srem -> - let (path, arg) = Typedecl.transl_exn_rebind env loc longid in - let (id, newenv) = Env.enter_exception name arg env in + | Pstr_exn_rebind(name, longid) -> + let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in + let (id, newenv) = Env.enter_exception name.txt arg env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_exn_rebind(id, path) :: str_rem, - Tsig_exception(id, arg) :: sig_rem, + (mkstr (Tstr_exn_rebind(id, name, path, longid)) loc :: str_rem, + Sig_exception(id, arg) :: sig_rem, final_env) - | {pstr_desc = Pstr_module(name, smodl); pstr_loc = loc} :: srem -> - check "module" loc module_names name; + | Pstr_module(name, smodl) -> + check "module" loc module_names name.txt; let modl = - type_module true funct_body (anchor_submodule name anchor) env + type_module true funct_body (anchor_submodule name.txt anchor) env smodl in - let mty = enrich_module_type anchor name modl.mod_type env in - let (id, newenv) = Env.enter_module name mty env in + let mty = enrich_module_type anchor name.txt modl.mod_type env in + let (id, newenv) = Env.enter_module name.txt mty env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_module(id, modl) :: str_rem, - Tsig_module(id, modl.mod_type, Trec_not) :: sig_rem, + (mkstr (Tstr_module(id, name, modl)) loc :: str_rem, + Sig_module(id, modl.mod_type, Trec_not) :: sig_rem, final_env) - | {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem -> + | Pstr_recmodule sbind -> List.iter - (fun (name, _, _) -> check "module" loc module_names name) + (fun (name, _, _) -> check "module" loc module_names name.txt) sbind; let (decls, newenv) = transl_recmodule_modtypes loc env (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in let bindings1 = List.map2 - (fun (id, mty) (name, smty, smodl) -> + (fun (id, _, mty) (name, _, smodl) -> let modl = type_module true funct_body (anchor_recmodule id anchor) newenv smodl in let mty' = enrich_module_type anchor (Ident.name id) modl.mod_type newenv in - (id, mty, modl, mty')) + (id, name, mty, modl, mty')) decls sbind in let bindings2 = check_recmodule_inclusion newenv bindings1 in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_recmodule bindings2 :: str_rem, - map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs)) + (mkstr (Tstr_recmodule bindings2) loc :: str_rem, + map_rec (fun rs (id, _, _, modl) -> Sig_module(id, modl.mod_type, rs)) bindings2 sig_rem, final_env) - | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem -> - check "module type" loc modtype_names name; + | Pstr_modtype(name, smty) -> + check "module type" loc modtype_names name.txt; let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_modtype name (Tmodtype_manifest mty) env in + let (id, newenv) = + Env.enter_modtype name.txt (Modtype_manifest mty.mty_type) env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_modtype(id, mty) :: str_rem, - Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem, + (mkstr (Tstr_modtype(id, name, mty)) loc :: str_rem, + Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem, final_env) - | {pstr_desc = Pstr_open lid; pstr_loc = loc} :: srem -> - type_struct (type_open env loc lid) srem - | {pstr_desc = Pstr_class cl; pstr_loc = loc} :: srem -> + | Pstr_open (lid) -> + let (path, newenv) = type_open ~toplevel env loc lid in + let (str_rem, sig_rem, final_env) = type_struct newenv srem in + (mkstr (Tstr_open (path, lid)) loc :: str_rem, sig_rem, final_env) + | Pstr_class cl -> List.iter - (fun {pci_name = name} -> check "type" loc type_names name) + (fun {pci_name = name} -> check "type" loc type_names name.txt) cl; let (classes, new_env) = Typeclass.class_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (Tstr_class - (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) -> + (mkstr (Tstr_class + (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) -> let vf = if d.cty_new = None then Virtual else Concrete in - (i, s, m, c, vf)) classes) :: - Tstr_cltype - (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) :: + (* (i, s, m, c, vf) *) (c, m, vf)) classes)) loc :: +(* TODO: check with Jacques why this is here + Tstr_class_type + (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: Tstr_type (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: Tstr_type (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: +*) str_rem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) -> - [Tsig_class(i, d, rs); - Tsig_cltype(i', d', rs); - Tsig_type(i'', d'', rs); - Tsig_type(i''', d''', rs)]) + (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) -> + [Sig_class(i, d, rs); + Sig_class_type(i', d', rs); + Sig_type(i'', d'', rs); + Sig_type(i''', d''', rs)]) classes [sig_rem]), final_env) - | {pstr_desc = Pstr_class_type cl; pstr_loc = loc} :: srem -> + | Pstr_class_type cl -> List.iter - (fun {pci_name = name} -> check "type" loc type_names name) + (fun {pci_name = name} -> check "type" loc type_names name.txt) cl; let (classes, new_env) = Typeclass.class_type_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (Tstr_cltype - (List.map (fun (i, d, _, _, _, _) -> (i, d)) classes) :: - Tstr_type + (mkstr (Tstr_class_type + (List.map (fun (i, i_loc, d, _, _, _, _, c) -> + (i, i_loc, c)) classes)) loc :: +(* TODO: check with Jacques why this is here + Tstr_type (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: + (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) str_rem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'') -> - [Tsig_cltype(i, d, rs); - Tsig_type(i', d', rs); - Tsig_type(i'', d'', rs)]) + (fun rs (i, _, d, i', d', i'', d'', _) -> + [Sig_class_type(i, d, rs); + Sig_type(i', d', rs); + Sig_type(i'', d'', rs)]) classes [sig_rem]), final_env) - | {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem -> + | Pstr_include smodl -> let modl = type_module true funct_body None env smodl in (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity @@ -989,29 +1106,58 @@ and type_structure funct_body anchor env sstr scope = (check_sig_item type_names module_names modtype_names loc) sg; let new_env = Env.add_signature sg env in let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (Tstr_include (modl, bound_value_identifiers sg) :: str_rem, + (mkstr (Tstr_include (modl, bound_value_identifiers sg)) loc :: str_rem, sg @ sig_rem, final_env) +(*>JOCAML *) + | Pstr_def sdefs -> + let scope = +(* scope is non-recursive (recursive calls use optimised bindings?) *) + let start = match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in + Some (Annot.Idef {scope with Location.loc_start = start}) in + let (defs, newenv) = + Typecore.type_joindefinition env sdefs scope in + let (str_rem, sig_rem, final_env) = type_struct newenv srem in + let bound_idents = Typedtree.def_bound_idents defs in + (mkstr (Tstr_def defs) loc :: str_rem, + map_end (make_sig_channel_value newenv) bound_idents sig_rem, + final_env) + | Pstr_exn_global longid -> + let path = Typedecl.transl_exn_global env loc longid.txt in + let (str_rem, sig_rem, final_env) = type_struct env srem in + (mkstr (Tstr_exn_global (path,longid)) loc:: str_rem, + sig_rem, + final_env) +(*<JOCAML *) in - if !Clflags.annotations - then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; - type_struct env sstr - + if !Clflags.annotations then + (* moved to genannot *) + List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; + let previous_saved_types = Cmt_format.get_saved_types () in + let (items, sg, final_env) = type_struct env sstr in + let str = { str_items = items; str_type = sg; str_final_env = final_env } in + Cmt_format.set_saved_types + (Cmt_format.Partial_structure str :: previous_saved_types); + str, sg, final_env + +let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none let type_module = type_module true false None let type_structure = type_structure false None (* Normalize types in a signature *) let rec normalize_modtype env = function - Tmty_ident p -> () - | Tmty_signature sg -> normalize_signature env sg - | Tmty_functor(id, param, body) -> normalize_modtype env body + Mty_ident p -> () + | Mty_signature sg -> normalize_signature env sg + | Mty_functor(id, param, body) -> normalize_modtype env body and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function - Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type - | Tsig_module(id, mty, _) -> normalize_modtype env mty + Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type + | Sig_module(id, mty, _) -> normalize_modtype env mty | _ -> () (* Simplify multiple specifications of a value or an exception in a signature. @@ -1021,26 +1167,26 @@ and normalize_signature_item env = function let rec simplify_modtype mty = match mty with - Tmty_ident path -> mty - | Tmty_functor(id, arg, res) -> Tmty_functor(id, arg, simplify_modtype res) - | Tmty_signature sg -> Tmty_signature(simplify_signature sg) + Mty_ident path -> mty + | Mty_functor(id, arg, res) -> Mty_functor(id, arg, simplify_modtype res) + | Mty_signature sg -> Mty_signature(simplify_signature sg) and simplify_signature sg = let rec simplif val_names exn_names res = function [] -> res - | (Tsig_value(id, descr) as component) :: sg -> + | (Sig_value(id, descr) as component) :: sg -> let name = Ident.name id in simplif (StringSet.add name val_names) exn_names (if StringSet.mem name val_names then res else component :: res) sg - | (Tsig_exception(id, decl) as component) :: sg -> + | (Sig_exception(id, decl) as component) :: sg -> let name = Ident.name id in simplif val_names (StringSet.add name exn_names) (if StringSet.mem name exn_names then res else component :: res) sg - | Tsig_module(id, mty, rs) :: sg -> + | Sig_module(id, mty, rs) :: sg -> simplif val_names exn_names - (Tsig_module(id, simplify_modtype mty, rs) :: res) sg + (Sig_module(id, simplify_modtype mty, rs) :: res) sg | component :: sg -> simplif val_names exn_names (component :: res) sg in @@ -1049,23 +1195,28 @@ and simplify_signature sg = (* Extract the module type of a module expression *) let type_module_type_of env smod = - let mty = + let tmty = match smod.pmod_desc with | Pmod_ident lid -> (* turn off strengthening in this case *) - let (path, mty) = Typetexp.find_module env smod.pmod_loc lid in mty - | _ -> (type_module env smod).mod_type in + let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in + rm { mod_desc = Tmod_ident (path, lid); + mod_type = mty; + mod_env = env; + mod_loc = smod.pmod_loc } + | _ -> type_module env smod in + let mty = tmty.mod_type in (* PR#5037: clean up inferred signature to remove duplicate specs *) let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype mty) then raise(Error(smod.pmod_loc, Non_generalizable_module mty)); - mty + tmty, mty (* For Typecore *) let rec get_manifest_types = function [] -> [] - | Tsig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem -> + | Sig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem -> (Ident.name id, ty) :: get_manifest_types rem | _ :: rem -> get_manifest_types rem @@ -1081,7 +1232,7 @@ let type_package env m p nl tl = Typetexp.widen context; let (mp, env) = match modl.mod_desc with - Tmod_ident mp -> (mp, env) + Tmod_ident (mp,_) -> (mp, env) | _ -> let (id, new_env) = Env.enter_module "%M" modl.mod_type env in (Pident id, new_env) @@ -1095,14 +1246,15 @@ let type_package env m p nl 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 + if nl = [] then + (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) + 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') + (wrap_constraint env modl mty Tmodtype_implicit, tl') (* Fill in the forward declarations *) let () = @@ -1116,6 +1268,8 @@ let () = (* Typecheck an implementation file *) let type_implementation sourcefile outputprefix modulename initial_env ast = + Cmt_format.set_saved_types []; + try Typecore.reset_delayed_checks (); let (str, sg, finalenv) = type_structure initial_env ast Location.none in let simple_sg = simplify_signature sg in @@ -1137,9 +1291,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (* 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. *) + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; (str, coercion) end else begin - check_nongen_schemes finalenv str; + check_nongen_schemes finalenv str.str_items; normalize_signature finalenv simple_sg; let coercion = Includemod.compunit sourcefile sg @@ -1149,11 +1305,27 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = 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"); + if not !Clflags.dont_write_files then begin + let sg = + Env.save_signature simple_sg modulename (outputprefix ^ ".cmi") in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) + (Some sourcefile) initial_env (Some sg); + end; (str, coercion) end - end + end + with e -> + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ()))) + (Some sourcefile) initial_env None; + raise e + + +let save_signature modname tsg outputprefix source_file initial_env cmi = + Cmt_format.save_cmt (outputprefix ^ ".cmti") modname + (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) (* "Packaging" of several compilation units into one unit having them as sub-modules. *) @@ -1164,7 +1336,7 @@ let rec package_signatures subst = function let sg' = Subst.signature subst sg in let oldid = Ident.create_persistent name and newid = Ident.create name in - Tsig_module(newid, Tmty_signature sg', Trec_not) :: + Sig_module(newid, Mty_signature sg', Trec_not) :: package_signatures (Subst.add_module oldid (Pident newid) subst) rem let package_units objfiles cmifile modulename = @@ -1184,13 +1356,15 @@ let package_units objfiles cmifile modulename = Ident.reinit(); let sg = package_signatures Subst.identity units in (* See if explicit interface is provided *) - let mlifile = - chop_extension_if_any cmifile ^ !Config.interface_suffix in + let prefix = chop_extension_if_any cmifile in + let mlifile = prefix ^ !Config.interface_suffix in if Sys.file_exists mlifile then begin if not (Sys.file_exists cmifile) then begin raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile)) end; let dclsig = Env.read_signature modulename cmifile in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None Env.initial None ; Includemod.compunit "(obtained by packing)" sg mlifile dclsig end else begin (* Determine imports *) @@ -1200,7 +1374,13 @@ let package_units objfiles cmifile modulename = (fun (name, crc) -> not (List.mem name unit_names)) (Env.imported_units()) in (* Write packaged signature *) - Env.save_signature_with_imports sg modulename cmifile imports; + if not !Clflags.dont_write_files then begin + let sg = + Env.save_signature_with_imports sg modulename + (prefix ^ ".cmi") imports in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None Env.initial (Some sg) + end; Tcoerce_none end diff --git a/typing/typemod.mli b/typing/typemod.mli index a2c03aaa83..c339825d99 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -21,20 +21,28 @@ val type_module: Env.t -> Parsetree.module_expr -> Typedtree.module_expr val type_structure: Env.t -> Parsetree.structure -> Location.t -> - Typedtree.structure * signature * Env.t + Typedtree.structure * Types.signature * Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Env.t val type_implementation: - string -> string -> string -> Env.t -> Parsetree.structure -> - Typedtree.structure * Typedtree.module_coercion + string -> string -> string -> Env.t -> Parsetree.structure -> + Typedtree.structure * Typedtree.module_coercion val transl_signature: - Env.t -> Parsetree.signature -> signature + Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_schemes: - Env.t -> Typedtree.structure -> unit + Env.t -> Typedtree.structure_item list -> unit val simplify_signature: signature -> signature +val save_signature : string -> Typedtree.signature -> string -> string -> + Env.t -> Types.signature_item list -> unit + val package_units: string list -> string -> string -> Typedtree.module_coercion +val bound_value_identifiers : Types.signature_item list -> Ident.t list + type error = Cannot_apply of module_type | Not_included of Includemod.error list diff --git a/typing/types.ml b/typing/types.ml index a50901cb06..00d8396f74 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -174,8 +174,8 @@ type type_declaration = and type_kind = Type_abstract | Type_record of - (string * mutable_flag * type_expr) list * record_representation - | Type_variant of (string * type_expr list * type_expr option) list + (Ident.t * mutable_flag * type_expr) list * record_representation + | Type_variant of (Ident.t * type_expr list * type_expr option) list type exception_declaration = { exn_args: type_expr list; @@ -186,9 +186,9 @@ type exception_declaration = module Concr = Set.Make(OrderedString) type class_type = - Tcty_constr of Path.t * type_expr list * class_type - | Tcty_signature of class_signature - | Tcty_fun of label * type_expr * class_type + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; @@ -204,7 +204,7 @@ type class_declaration = cty_new: type_expr option; cty_variance: (bool * bool) list } -type cltype_declaration = +type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; @@ -213,24 +213,24 @@ type cltype_declaration = (* Type expressions for the module language *) type module_type = - Tmty_ident of Path.t - | Tmty_signature of signature - | Tmty_functor of Ident.t * module_type * module_type + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of Ident.t * module_type * module_type and signature = signature_item list and signature_item = - Tsig_value of Ident.t * value_description - | Tsig_type of Ident.t * type_declaration * rec_status - | Tsig_exception of Ident.t * exception_declaration - | Tsig_module of Ident.t * module_type * rec_status - | Tsig_modtype of Ident.t * modtype_declaration - | Tsig_class of Ident.t * class_declaration * rec_status - | Tsig_cltype of Ident.t * cltype_declaration * rec_status + Sig_value of Ident.t * value_description + | Sig_type of Ident.t * type_declaration * rec_status + | Sig_exception of Ident.t * exception_declaration + | Sig_module of Ident.t * module_type * rec_status + | Sig_modtype of Ident.t * modtype_declaration + | Sig_class of Ident.t * class_declaration * rec_status + | Sig_class_type of Ident.t * class_type_declaration * rec_status and modtype_declaration = - Tmodtype_abstract - | Tmodtype_manifest of module_type + Modtype_abstract + | Modtype_manifest of module_type and rec_status = Trec_not (* not recursive *) diff --git a/typing/types.mli b/typing/types.mli index 1138eb4aae..96b9710083 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -173,8 +173,8 @@ type type_declaration = and type_kind = Type_abstract | Type_record of - (string * mutable_flag * type_expr) list * record_representation - | Type_variant of (string * type_expr list * type_expr option) list + (Ident.t * mutable_flag * type_expr) list * record_representation + | Type_variant of (Ident.t * type_expr list * type_expr option) list type exception_declaration = { exn_args: type_expr list; @@ -185,9 +185,9 @@ type exception_declaration = module Concr : Set.S with type elt = string type class_type = - Tcty_constr of Path.t * type_expr list * class_type - | Tcty_signature of class_signature - | Tcty_fun of label * type_expr * class_type + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; @@ -202,7 +202,7 @@ type class_declaration = cty_new: type_expr option; cty_variance: (bool * bool) list } -type cltype_declaration = +type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; @@ -211,24 +211,24 @@ type cltype_declaration = (* Type expressions for the module language *) type module_type = - Tmty_ident of Path.t - | Tmty_signature of signature - | Tmty_functor of Ident.t * module_type * module_type + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of Ident.t * module_type * module_type and signature = signature_item list and signature_item = - Tsig_value of Ident.t * value_description - | Tsig_type of Ident.t * type_declaration * rec_status - | Tsig_exception of Ident.t * exception_declaration - | Tsig_module of Ident.t * module_type * rec_status - | Tsig_modtype of Ident.t * modtype_declaration - | Tsig_class of Ident.t * class_declaration * rec_status - | Tsig_cltype of Ident.t * cltype_declaration * rec_status + Sig_value of Ident.t * value_description + | Sig_type of Ident.t * type_declaration * rec_status + | Sig_exception of Ident.t * exception_declaration + | Sig_module of Ident.t * module_type * rec_status + | Sig_modtype of Ident.t * modtype_declaration + | Sig_class of Ident.t * class_declaration * rec_status + | Sig_class_type of Ident.t * class_type_declaration * rec_status and modtype_declaration = - Tmodtype_abstract - | Tmodtype_manifest of module_type + Modtype_abstract + | Modtype_manifest of module_type and rec_status = Trec_not (* not recursive *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 131b12a793..5f9c6caf52 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -14,8 +14,10 @@ (* Typechecking of type expressions for the core language *) +open Asttypes open Misc open Parsetree +open Typedtree open Types open Ctype @@ -101,7 +103,7 @@ 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 = +let find_class_type = find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) (* Support for first-class modules. *) @@ -113,7 +115,8 @@ let create_package_mty fake loc env (p, l) = let l = List.sort (fun (s1, t1) (s2, t2) -> - if s1 = s2 then raise (Error (loc, Multiple_constraints_on_type s1)); + if s1.txt = s2.txt then + raise (Error (loc, Multiple_constraints_on_type s1.txt)); compare s1 s2) l in @@ -127,7 +130,7 @@ 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, [ s, Pwith_type d ]); + {pmty_desc=Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]); pmty_loc=loc} ) {pmty_desc=Pmty_ident p; pmty_loc=loc} @@ -195,14 +198,22 @@ let rec swap_list = function type policy = Fixed | Extensible | Univars +let ctyp ctyp_desc ctyp_type ctyp_env ctyp_loc = + { ctyp_desc; ctyp_type; ctyp_env; ctyp_loc } + let rec transl_type env policy styp = + let loc = styp.ptyp_loc in match styp.ptyp_desc with Ptyp_any -> - if policy = Univars then new_pre_univar () else - if policy = Fixed then - raise (Error (styp.ptyp_loc, Unbound_type_variable "_")) - else newvar () + let ty = + if policy = Univars then new_pre_univar () else + if policy = Fixed then + raise (Error (styp.ptyp_loc, Unbound_type_variable "_")) + else newvar () + in + ctyp Ttyp_any ty env loc | Ptyp_var name -> + let ty = if name <> "" && name.[0] = '_' then raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name))); begin try @@ -216,16 +227,21 @@ let rec transl_type env policy styp = used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; v end + in + ctyp (Ttyp_var name) ty env loc | Ptyp_arrow(l, st1, st2) -> - let ty1 = transl_type env policy st1 in - let ty2 = transl_type env policy st2 in - newty (Tarrow(l, ty1, ty2, Cok)) + let cty1 = transl_type env policy st1 in + let cty2 = transl_type env policy st2 in + let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in + ctyp (Ttyp_arrow (l, cty1, cty2)) ty env loc | Ptyp_tuple stl -> - newty (Ttuple(List.map (transl_type env policy) stl)) + let ctys = List.map (transl_type env policy) stl in + let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in + ctyp (Ttyp_tuple ctys) ty env loc | Ptyp_constr(lid, stl) -> - let (path, decl) = find_type env styp.ptyp_loc lid in + let (path, decl) = find_type env styp.ptyp_loc lid.txt in if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity, + raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in @@ -236,23 +252,36 @@ let rec transl_type env policy styp = if (repr ty).level = Btype.generic_level then unify_var else unify in List.iter2 - (fun (sty, ty) ty' -> - try unify_param env ty' ty with Unify trace -> + (fun (sty, cty) ty' -> + try unify_param env ty' cty.ctyp_type with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) (List.combine stl args) params; - let constr = newconstr path args in + let constr = + newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in begin try Ctype.enforce_constraints env constr with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) end; - constr + ctyp (Ttyp_constr (path, lid, args)) constr env loc | Ptyp_object fields -> - newobj (transl_fields env policy [] fields) + let fields = List.map + (fun pf -> + let desc = + match pf.pfield_desc with + | Pfield_var -> Tcfield_var + | Pfield (s,e) -> + let ty1 = transl_type env policy e in + Tcfield (s, ty1) + in + { field_desc = desc; field_loc = pf.pfield_loc }) + fields in + let ty = newobj (transl_fields env policy [] fields) in + ctyp (Ttyp_object fields) ty env loc | Ptyp_class(lid, stl, present) -> let (path, decl, is_variant) = try - let (path, decl) = Env.lookup_type lid env in + let (path, decl) = Env.lookup_type lid.txt env in let rec check decl = match decl.type_manifest with None -> raise Not_found @@ -268,7 +297,7 @@ let rec transl_type env policy styp = with Not_found -> try if present <> [] then raise Not_found; let lid2 = - match lid with + match lid.txt with Longident.Lident s -> Longident.Lident ("#" ^ s) | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" @@ -276,24 +305,25 @@ let rec transl_type env policy styp = let (path, decl) = Env.lookup_type lid2 env in (path, decl, false) with Not_found -> - raise(Error(styp.ptyp_loc, Unbound_class lid)) + raise(Error(styp.ptyp_loc, Unbound_class lid.txt)) in if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity, + raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in List.iter2 - (fun (sty, ty) ty' -> - try unify_var env ty' ty with Unify trace -> + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in let ty = - try Ctype.expand_head env (newconstr path args) + try Ctype.expand_head env (newconstr path ty_args) with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) in - begin match ty.desc with + let ty = match ty.desc with Tvariant row -> let row = Btype.row_repr row in List.iter @@ -313,7 +343,7 @@ let rec transl_type env policy styp = row.row_fields in let row = { row_closed = true; row_fields = fields; - row_bound = (); row_name = Some (path, args); + row_bound = (); row_name = Some (path, ty_args); row_fixed = false; row_more = newvar () } in let static = Btype.static_row row in let row = @@ -328,9 +358,10 @@ let rec transl_type env policy styp = ty | _ -> assert false - end + in + ctyp (Ttyp_class (path, lid, args, present)) ty env loc | Ptyp_alias(st, alias) -> - begin + let cty = try let t = try List.assoc alias !univars @@ -338,7 +369,7 @@ let rec transl_type env policy styp = 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 -> + begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; @@ -348,7 +379,7 @@ let rec transl_type env policy styp = let t = newvar () in used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; let ty = transl_type env policy st in - begin try unify_var env t ty with Unify trace -> + begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; @@ -363,8 +394,9 @@ let rec transl_type env policy styp = | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) | _ -> () end; - t - end + { ty with ctyp_type = t } + in + ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type env loc | Ptyp_variant(fields, closed, present) -> let name = ref None in let mkfield l f = @@ -388,21 +420,25 @@ let rec transl_type env policy styp = let rec add_field = function Rtag (l, c, stl) -> name := None; + let tl = List.map (transl_type env policy) stl in let f = match present with Some present when not (List.mem l present) -> - let tl = List.map (transl_type env policy) stl in - Reither(c, tl, false, ref None) + let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in + Reither(c, ty_tl, false, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then raise(Error(styp.ptyp_loc, Present_has_conjunction l)); - match stl with [] -> Rpresent None - | st :: _ -> Rpresent (Some(transl_type env policy st)) + match tl with [] -> Rpresent None + | st :: _ -> + Rpresent (Some st.ctyp_type) in - add_typed_field styp.ptyp_loc l f + add_typed_field styp.ptyp_loc l f; + Ttag (l,c,tl) | Rinherit sty -> - let ty = transl_type env policy sty in + let cty = transl_type env policy sty in + let ty = cty.ctyp_type in let nm = - match repr ty with + match repr cty.ctyp_type with {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in @@ -414,7 +450,7 @@ let rec transl_type env policy styp = (* Unset it otherwise *) name := None end; - let fl = match expand_head env ty, nm with + let fl = match expand_head env cty.ctyp_type, nm with {desc=Tvariant row}, _ when Btype.static_row row -> let row = Btype.row_repr row in row.row_fields @@ -438,9 +474,10 @@ let rec transl_type env policy styp = | _ -> f in add_typed_field sty.ptyp_loc l f) - fl + fl; + Tinherit cty in - List.iter add_field fields; + let tfields = List.map add_field fields in let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in begin match present with None -> () | Some present -> @@ -459,13 +496,15 @@ let rec transl_type env policy styp = else if policy <> Univars then row else { row with row_more = new_pre_univar () } in - newty (Tvariant row) - | Ptyp_poly(vars, st) -> + let ty = newty (Tvariant row) in + ctyp (Ttyp_variant (tfields, closed, present)) ty env loc + | Ptyp_poly(vars, st) -> begin_def(); 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 + let cty = transl_type env policy st in + let ty = cty.ctyp_type in univars := old_univars; end_def(); generalize ty; @@ -485,28 +524,37 @@ let rec transl_type env policy styp = in let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in unify_var env (newvar()) ty'; - ty' + ctyp (Ttyp_poly (vars, cty)) ty' env loc | Ptyp_package (p, l) -> let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in let z = narrow () in - ignore (!transl_modtype env mty); + let mty = !transl_modtype env mty in widen z; - newty (Tpackage (!transl_modtype_longident styp.ptyp_loc env p, - List.map fst l, - List.map (transl_type env policy) (List.map snd l))) + let ptys = List.map (fun (s, pty) -> + s, transl_type env policy pty + ) l in + let path = !transl_modtype_longident styp.ptyp_loc env p.txt in + let ty = newty (Tpackage (path, + List.map (fun (s, pty) -> s.txt) l, + List.map (fun (_,cty) -> cty.ctyp_type) ptys)) + in + ctyp (Ttyp_package { + pack_name = path; + pack_type = mty.mty_type; + pack_fields = ptys; + pack_txt = p; + }) ty env loc and transl_fields env policy seen = function [] -> newty Tnil - | {pfield_desc = Pfield_var}::_ -> + | {field_desc = Tcfield_var}::_ -> if policy = Univars then new_pre_univar () else newvar () - | {pfield_desc = Pfield(s, e); pfield_loc = loc}::l -> + | {field_desc = Tcfield(s, ty1); field_loc = loc}::l -> if List.mem s seen then raise (Error (loc, Repeated_method_label s)); - let ty1 = transl_type env policy e in let ty2 = transl_fields env policy (s::seen) l in - newty (Tfield (s, Fpresent, ty1, ty2)) - + newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2)) (* Make the rows "fixed" in this type, to make universal check easier *) let rec make_fixed_univars ty = @@ -563,7 +611,7 @@ let transl_simple_type env fixed styp = univars := []; used_variables := Tbl.empty; let typ = transl_type env (if fixed then Fixed else Extensible) styp in globalize_used_variables env fixed (); - make_fixed_univars typ; + make_fixed_univars typ.ctyp_type; typ let transl_simple_type_univars env styp = @@ -580,7 +628,7 @@ let transl_simple_type_univars env styp = new_variables; globalize_used_variables env false (); end_def (); - generalize typ; + generalize typ.ctyp_type; let univs = List.fold_left (fun acc v -> @@ -591,13 +639,14 @@ let transl_simple_type_univars env styp = | _ -> acc) [] !pre_univars in - make_fixed_univars typ; - instance env (Btype.newgenty (Tpoly (typ, univs))) + make_fixed_univars typ.ctyp_type; + { typ with ctyp_type = + instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } let transl_simple_type_delayed env styp = univars := []; used_variables := Tbl.empty; let typ = transl_type env Extensible styp in - make_fixed_univars typ; + make_fixed_univars typ.ctyp_type; (typ, globalize_used_variables env false) let transl_type_scheme env styp = @@ -605,7 +654,7 @@ let transl_type_scheme env styp = begin_def(); let typ = transl_simple_type env false styp in end_def(); - generalize typ; + generalize typ.ctyp_type; typ diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 79082d5f5e..0b6d09d30f 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -17,15 +17,15 @@ open Format;; val transl_simple_type: - Env.t -> bool -> Parsetree.core_type -> Types.type_expr + Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_univars: - Env.t -> Parsetree.core_type -> Types.type_expr + Env.t -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_delayed: - Env.t -> Parsetree.core_type -> Types.type_expr * (unit -> unit) + Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) (* Translate a type, but leave type variables unbound. Returns the type and a function that binds the type variable. *) val transl_type_scheme: - Env.t -> Parsetree.core_type -> Types.type_expr + Env.t -> Parsetree.core_type -> Typedtree.core_type val reset_type_variables: unit -> unit val enter_type_variable: bool -> Location.t -> string -> Types.type_expr val type_variable: Location.t -> string -> Types.type_expr @@ -69,15 +69,28 @@ exception Error of Location.t * error 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 -> (Longident.t * Parsetree.core_type) list * Parsetree.module_type +val transl_modtype_longident: (* from Typemod *) + (Location.t -> Env.t -> Longident.t -> Path.t) ref +val transl_modtype: (* from Typemod *) + (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref +val create_package_mty: + Location.t -> Env.t -> Parsetree.package_type -> + (Longident.t Asttypes.loc * 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 -val find_label: Env.t -> Location.t -> Longident.t -> Types.label_description -val find_value: Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description -val find_class: Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration -val find_module: Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type -val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration -val find_cltype: Env.t -> Location.t -> Longident.t -> Path.t * Types.cltype_declaration +val find_type: + Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration +val find_constructor: + Env.t -> Location.t -> Longident.t -> Path.t * Types.constructor_description +val find_label: + Env.t -> Location.t -> Longident.t -> Path.t * Types.label_description +val find_value: + Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description +val find_class: + Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration +val find_module: + Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type +val find_modtype: + Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration +val find_class_type: + Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration diff --git a/utils/clflags.ml b/utils/clflags.ml index d05002f900..5b8c73e56e 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -38,6 +38,7 @@ let annotations = ref false (* -annot *) and nojoin = ref false (* -nojoin *) (*< JOCAML *) and use_threads = ref true (* JOCAML*) (* -thread *) +let binary_annotations = ref false (* -annot *) and use_vmthreads = ref false (* -vmthread *) and noassert = ref false (* -noassert *) and verbose = ref false (* -verbose *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 5ea199bea8..c0115e3415 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -32,6 +32,7 @@ val nopervasives : bool ref val preprocessor : string option ref val annotations : bool ref val nojoin : bool ref +val binary_annotations : bool ref val use_threads : bool ref val use_vmthreads : bool ref val noassert : bool ref @@ -81,3 +82,4 @@ 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 ca6e6d4767..06fc7da2b5 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -62,14 +62,15 @@ let mkexe = C.mkexe let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I013" +and cmi_magic_number = "Caml1999I014" 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 = "Caml1999M014" -and ast_intf_magic_number = "Caml1999N013" +and ast_impl_magic_number = "Caml1999M015" +and ast_intf_magic_number = "Caml1999N014" and cmxs_magic_number = "Caml2007D001" +and cmt_magic_number = "Caml2012T001" let load_path = ref ([] : string list) diff --git a/utils/config.mli b/utils/config.mli index af8c407de0..47cc3cd56b 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -19,7 +19,7 @@ val version: string val standard_library: string (* The directory containing the standard libraries *) -val ocaml_library : string option +val ocaml_library: string option (* The directory containing the standard libraries of ocaml, or None if no companion ocaml *) @@ -79,6 +79,8 @@ val ast_impl_magic_number: string (* Magic number for file holding an implementation syntax tree *) val cmxs_magic_number: string (* Magic number for dynamically-loadable plugins *) +val cmt_magic_number: string + (* Magic number for compiled interface files *) val max_tag: int (* Biggest tag that can be stored in the header of a regular block. *) diff --git a/utils/config.mlp b/utils/config.mlp index 31bacf3080..1120cd7052 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -55,14 +55,15 @@ let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I013" +and cmi_magic_number = "Caml1999I014" 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 = "Caml1999M014" -and ast_intf_magic_number = "Caml1999N013" +and ast_impl_magic_number = "Caml1999M015" +and ast_intf_magic_number = "Caml1999N014" and cmxs_magic_number = "Caml2007D001" +and cmt_magic_number = "Caml2012T001" let load_path = ref ([] : string list) @@ -124,5 +125,10 @@ let print_config oc = p "os_type" Sys.os_type; p "default_executable_name" default_executable_name; p_bool "systhread_supported" systhread_supported; +(*>JOCAML *) + p "companion OCaml" + (match ocaml_library with None -> "None" + | Some s -> s) ; +(*<JOCAML *) flush oc; ;; diff --git a/utils/misc.ml b/utils/misc.ml index a502bf545f..ae3228f233 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -29,6 +29,10 @@ let try_finally work cleanup = (* List functions *) +let as_cons = function + | x::xs -> x,xs + | [] -> assert false + let rec map_end f l1 l2 = match l1 with [] -> l2 @@ -156,6 +160,17 @@ let copy_file_chunk ic oc len = end in copy len +let string_of_file ic = + let b = Buffer.create 0x10000 in + let buff = String.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then Buffer.contents b else + (Buffer.add_substring b buff 0 n; copy()) + in copy() + + + (* Reading from a channel *) let input_bytes ic n = @@ -220,3 +235,12 @@ let rev_split_words s = let get_ref r = let v = !r in r := []; v + +let fst3 (x, _, _) = x +let snd3 (_,x,_) = x +let thd3 (_,_,x) = x + +let fst4 (x, _, _, _) = x +let snd4 (_,x,_, _) = x +let thd4 (_,_,x,_) = x + diff --git a/utils/misc.mli b/utils/misc.mli index 10f5a20a15..4d3bfee106 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -19,6 +19,8 @@ exception Fatal_error val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;; +val as_cons : 'a list -> 'a * 'a list + (* [as_cons (x::xs) returns x,xs; fails on [] *) val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list (* [map_end f l t] is [map f l @ t], just more efficient. *) val map_left_right: ('a -> 'b) -> 'a list -> 'b list @@ -65,7 +67,9 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies them to [oc]. It raises [End_of_file] when encountering EOF on [ic]. *) - +val string_of_file: in_channel -> string + (* [string_of_file ic] reads the contents of file [ic] and copies + them to a string. It stops when encountering EOF on [ic]. *) val input_bytes : in_channel -> int -> string;; (* [input_bytes ic n] reads [n] bytes from [ic] and returns them in a new string. It raises [End_of_file] if EOF is encountered @@ -111,3 +115,12 @@ val rev_split_words: string -> string list 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. *) + + +val fst3: 'a * 'b * 'c -> 'a +val snd3: 'a * 'b * 'c -> 'b +val thd3: 'a * 'b * 'c -> 'c + +val fst4: 'a * 'b * 'c * 'd -> 'a +val snd4: 'a * 'b * 'c * 'd -> 'b +val thd4: 'a * 'b * 'c * 'd -> 'c diff --git a/utils/warnings.ml b/utils/warnings.ml index e6ea56e9a8..02621ea67f 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -56,8 +56,9 @@ type t = | Unused_type_declaration of string (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) - | Unused_constructor of string (* 37 *) - | Unused_exception of string (* 38 *) + | Unused_constructor of string * bool * bool (* 37 *) + | Unused_exception of string * bool (* 38 *) + | Unused_rec_flag (* 39 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -105,9 +106,10 @@ let number = function | Unused_ancestor _ -> 36 | Unused_constructor _ -> 37 | Unused_exception _ -> 38 + | Unused_rec_flag -> 39 ;; -let last_warning_number = 38;; +let last_warning_number = 39 (* Must be the max number returned by the [number] function. *) let letter = function @@ -123,7 +125,7 @@ let letter = function | 'h' -> [] | 'i' -> [] | 'j' -> [] - | 'k' -> [32; 33; 34; 35; 36; 37; 38] + | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] | 'l' -> [6] | 'm' -> [7] | 'n' -> [] @@ -202,7 +204,7 @@ let parse_opt flags s = let parse_options errflag s = parse_opt (if errflag then error else active) s;; (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-6-7-9-27-29-32..38";; +let defaults_w = "+a-4-6-7-9-27-29-32..39";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -235,7 +237,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." @@ -262,8 +264,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 -> @@ -285,8 +287,23 @@ let message = function | 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 -> "unused constructor " ^ s ^ "." - | Unused_exception s -> "unused exception constructor " ^ 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.)" + | Unused_rec_flag -> + "unused rec flag." ;; let nerrors = ref 0;; @@ -331,14 +348,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."; @@ -371,6 +388,7 @@ let descriptions = 36, "Unused ancestor variable."; 37, "Unused constructor."; 38, "Unused exception constructor."; + 39, "Unused rec flag."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 6cb7ce5615..fbffb33dfc 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -51,8 +51,9 @@ type t = | Unused_type_declaration of string (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) - | Unused_constructor of string (* 37 *) - | Unused_exception of string (* 38 *) + | Unused_constructor of string * bool * bool (* 37 *) + | Unused_exception of string * bool (* 38 *) + | Unused_rec_flag (* 39 *) ;; val parse_options : bool -> string -> unit;; diff --git a/yacc/.ignore b/yacc/.ignore index bf37bf6c4c..833c2dea6d 100644 --- a/yacc/.ignore +++ b/yacc/.ignore @@ -1,3 +1,4 @@ ocamlyacc +ocamlyacc.exe version.h .gdb_history |